Index: trunk/tests/functional_tests/Makefile.am =================================================================== --- trunk/tests/functional_tests/Makefile.am (revision 8215) +++ trunk/tests/functional_tests/Makefile.am (revision 8216) @@ -1,761 +1,762 @@ ## Makefile.am -- Makefile for executable WHIZARD test scripts ## ## Process this file with automake to produce Makefile.in ## ######################################################################## # # Copyright (C) 1999-2018 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 \ 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.tmp + mv $name.tmp $name.log + diff ref-output/$name.ref $name.log +else + echo "|=============================================================================|" + echo "No O'Mega matrix elements available, test skipped" + exit 77 +fi + Index: trunk/share/tests/Makefile.am =================================================================== --- trunk/share/tests/Makefile.am (revision 8215) +++ trunk/share/tests/Makefile.am (revision 8216) @@ -1,1381 +1,1383 @@ ## Makefile.am -- Makefile for WHIZARD tests ## ## Process this file with automake to produce Makefile.in ## ######################################################################## # # Copyright (C) 1999-2018 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/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/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/ref-output/model_change_3.ref =================================================================== --- trunk/share/tests/functional_tests/ref-output/model_change_3.ref (revision 0) +++ trunk/share/tests/functional_tests/ref-output/model_change_3.ref (revision 8216) @@ -0,0 +1 @@ +| There were no errors and 1 warning(s). Index: trunk/share/tests/functional_tests/model_change_3.sin =================================================================== --- trunk/share/tests/functional_tests/model_change_3.sin (revision 0) +++ trunk/share/tests/functional_tests/model_change_3.sin (revision 8216) @@ -0,0 +1,23 @@ +# SINDARIN input for WHIZARD self-test + +?logging = true +?openmp_logging = false +?vis_history = false +?integration_timer = false + +seed = 0 + +model = QED +process model_change_3p = e1, E1 => e2, E2 +compile + +sqrts = 200 GeV + +# Regression test (error: "variable '$model_name' is unknown" from 'integrate' inside scan) +scan int i = (1) { + + iterations = 1:100 # Defining a local setting to integrate makes the error go away! + integrate (model_change_3p) # {iterations = 1:100} + simulate (model_change_3p) { n_events = 1 } + +} Index: trunk/src/whizard-core/whizard.nw =================================================================== --- trunk/src/whizard-core/whizard.nw (revision 8215) +++ trunk/src/whizard-core/whizard.nw (revision 8216) @@ -1,31304 +1,31304 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD main code as NOWEB source \includemodulegraph{whizard-core} \chapter{Integration and Simulation} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{User-controlled File I/O} The SINDARIN language includes commands that write output to file (input may be added later). We identify files by their name, and manage the unit internally. We need procedures for opening, closing, and printing files. <<[[user_files.f90]]>>= <> module user_files <> use io_units use diagnostics use ifiles use analysis <> <> <> <> contains <> end module user_files @ %def user_files @ \subsection{The file type} This is a type that describes an open user file and its properties. The entry is part of a doubly-linked list. <>= type :: file_t private type(string_t) :: name integer :: unit = -1 logical :: reading = .false. logical :: writing = .false. type(file_t), pointer :: prev => null () type(file_t), pointer :: next => null () end type file_t @ %def file_t @ The initializer opens the file. <>= subroutine file_init (file, name, action, status, position) type(file_t), intent(out) :: file type(string_t), intent(in) :: name character(len=*), intent(in) :: action, status, position file%unit = free_unit () file%name = name open (unit = file%unit, file = char (file%name), & action = action, status = status, position = position) select case (action) case ("read") file%reading = .true. case ("write") file%writing = .true. case ("readwrite") file%reading = .true. file%writing = .true. end select end subroutine file_init @ %def file_init @ The finalizer closes it. <>= subroutine file_final (file) type(file_t), intent(inout) :: file close (unit = file%unit) file%unit = -1 end subroutine file_final @ %def file_final @ Check if a file is open with correct status. <>= function file_is_open (file, action) result (flag) logical :: flag type(file_t), intent(in) :: file character(*), intent(in) :: action select case (action) case ("read") flag = file%reading case ("write") flag = file%writing case ("readwrite") flag = file%reading .and. file%writing case default call msg_bug ("Checking file '" // char (file%name) & // "': illegal action specifier") end select end function file_is_open @ %def file_is_open @ Return the unit number of a file for direct access. It should be checked first whether the file is open. <>= function file_get_unit (file) result (unit) integer :: unit type(file_t), intent(in) :: file unit = file%unit end function file_get_unit @ %def file_get_unit @ Write to the file. Error if in wrong mode. If there is no string, just write an empty record. If there is a string, respect the [[advancing]] option. <>= subroutine file_write_string (file, string, advancing) type(file_t), intent(in) :: file type(string_t), intent(in), optional :: string logical, intent(in), optional :: advancing if (file%writing) then if (present (string)) then if (present (advancing)) then if (advancing) then write (file%unit, "(A)") char (string) else write (file%unit, "(A)", advance="no") char (string) end if else write (file%unit, "(A)") char (string) end if else write (file%unit, *) end if else call msg_error ("Writing to file: File '" // char (file%name) & // "' is not open for writing.") end if end subroutine file_write_string @ %def file_write @ Write a whole ifile, line by line. <>= subroutine file_write_ifile (file, ifile) type(file_t), intent(in) :: file type(ifile_t), intent(in) :: ifile type(line_p) :: line call line_init (line, ifile) do while (line_is_associated (line)) call file_write_string (file, line_get_string_advance (line)) end do end subroutine file_write_ifile @ %def file_write_ifile @ Write an analysis object (or all objects) to an open file. <>= subroutine file_write_analysis (file, tag) type(file_t), intent(in) :: file type(string_t), intent(in), optional :: tag if (file%writing) then if (present (tag)) then call analysis_write (tag, unit = file%unit) else call analysis_write (unit = file%unit) end if else call msg_error ("Writing analysis to file: File '" // char (file%name) & // "' is not open for writing.") end if end subroutine file_write_analysis @ %def file_write_analysis @ \subsection{The file list} We maintain a list of all open files and their attributes. The list must be doubly-linked because we may delete entries. <>= public :: file_list_t <>= type :: file_list_t type(file_t), pointer :: first => null () type(file_t), pointer :: last => null () end type file_list_t @ %def file_list_t @ There is no initialization routine, but a finalizer which deletes all: <>= public :: file_list_final <>= subroutine file_list_final (file_list) type(file_list_t), intent(inout) :: file_list type(file_t), pointer :: current do while (associated (file_list%first)) current => file_list%first file_list%first => current%next call file_final (current) deallocate (current) end do file_list%last => null () end subroutine file_list_final @ %def file_list_final @ Find an entry in the list. Return null pointer on failure. <>= function file_list_get_file_ptr (file_list, name) result (current) type(file_t), pointer :: current type(file_list_t), intent(in) :: file_list type(string_t), intent(in) :: name current => file_list%first do while (associated (current)) if (current%name == name) return current => current%next end do end function file_list_get_file_ptr @ %def file_list_get_file_ptr @ Check if a file is open, public version: <>= public :: file_list_is_open <>= function file_list_is_open (file_list, name, action) result (flag) logical :: flag type(file_list_t), intent(in) :: file_list type(string_t), intent(in) :: name character(len=*), intent(in) :: action type(file_t), pointer :: current current => file_list_get_file_ptr (file_list, name) if (associated (current)) then flag = file_is_open (current, action) else flag = .false. end if end function file_list_is_open @ %def file_list_is_open @ Return the unit number for a file. It should be checked first whether the file is open. <>= public :: file_list_get_unit <>= function file_list_get_unit (file_list, name) result (unit) integer :: unit type(file_list_t), intent(in) :: file_list type(string_t), intent(in) :: name type(file_t), pointer :: current current => file_list_get_file_ptr (file_list, name) if (associated (current)) then unit = file_get_unit (current) else unit = -1 end if end function file_list_get_unit @ %def file_list_get_unit @ Append a new file entry, i.e., open this file. Error if it is already open. <>= public :: file_list_open <>= subroutine file_list_open (file_list, name, action, status, position) type(file_list_t), intent(inout) :: file_list type(string_t), intent(in) :: name character(len=*), intent(in) :: action, status, position type(file_t), pointer :: current if (.not. associated (file_list_get_file_ptr (file_list, name))) then allocate (current) call msg_message ("Opening file '" // char (name) // "' for output") call file_init (current, name, action, status, position) if (associated (file_list%last)) then file_list%last%next => current current%prev => file_list%last else file_list%first => current end if file_list%last => current else call msg_error ("Opening file: File '" // char (name) & // "' is already open.") end if end subroutine file_list_open @ %def file_list_open @ Delete a file entry, i.e., close this file. Error if it is not open. <>= public :: file_list_close <>= subroutine file_list_close (file_list, name) type(file_list_t), intent(inout) :: file_list type(string_t), intent(in) :: name type(file_t), pointer :: current current => file_list_get_file_ptr (file_list, name) if (associated (current)) then if (associated (current%prev)) then current%prev%next => current%next else file_list%first => current%next end if if (associated (current%next)) then current%next%prev => current%prev else file_list%last => current%prev end if call msg_message ("Closing file '" // char (name) // "' for output") call file_final (current) deallocate (current) else call msg_error ("Closing file: File '" // char (name) & // "' is not open.") end if end subroutine file_list_close @ %def file_list_close @ Write a string to file. Error if it is not open. <>= public :: file_list_write <>= interface file_list_write module procedure file_list_write_string module procedure file_list_write_ifile end interface <>= subroutine file_list_write_string (file_list, name, string, advancing) type(file_list_t), intent(in) :: file_list type(string_t), intent(in) :: name type(string_t), intent(in), optional :: string logical, intent(in), optional :: advancing type(file_t), pointer :: current current => file_list_get_file_ptr (file_list, name) if (associated (current)) then call file_write_string (current, string, advancing) else call msg_error ("Writing to file: File '" // char (name) & // "'is not open.") end if end subroutine file_list_write_string subroutine file_list_write_ifile (file_list, name, ifile) type(file_list_t), intent(in) :: file_list type(string_t), intent(in) :: name type(ifile_t), intent(in) :: ifile type(file_t), pointer :: current current => file_list_get_file_ptr (file_list, name) if (associated (current)) then call file_write_ifile (current, ifile) else call msg_error ("Writing to file: File '" // char (name) & // "'is not open.") end if end subroutine file_list_write_ifile @ %def file_list_write @ Write an analysis object or all objects to data file. Error if it is not open. If the file name is empty, write to standard output. <>= public :: file_list_write_analysis <>= subroutine file_list_write_analysis (file_list, name, tag) type(file_list_t), intent(in) :: file_list type(string_t), intent(in) :: name type(string_t), intent(in), optional :: tag type(file_t), pointer :: current if (name == "") then if (present (tag)) then call analysis_write (tag) else call analysis_write end if else current => file_list_get_file_ptr (file_list, name) if (associated (current)) then call file_write_analysis (current, tag) else call msg_error ("Writing analysis to file: File '" // char (name) & // "' is not open.") end if end if end subroutine file_list_write_analysis @ %def file_list_write_analysis @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Runtime data} <<[[rt_data.f90]]>>= <> module rt_data <> <> use io_units use format_utils, only: write_separator use format_defs, only: FMT_19, FMT_12 use system_dependencies use diagnostics use os_interface use lexers use parser use models use subevents use pdg_arrays use variables, only: var_list_t use process_libraries use prclib_stacks use prc_core, only: helicity_selection_t use beam_structures use event_base, only: event_callback_t use user_files use process_stacks use iterations <> <> <> contains <> end module rt_data @ %def rt_data @ \subsection{Strategy for models and variables} The program manages its data via a main [[rt_data_t]] object. During program flow, various commands create and use local [[rt_data_t]] objects. Those transient blocks contain either pointers to global object or local copies which are deleted after use. Each [[rt_data_t]] object contains a variable list component. This lists holds (local copies of) all kinds of intrinsic or user-defined variables. The variable list is linked to the variable list contained in the local process library. This, in turn, is linked to the variable list of the [[rt_data_t]] context, and so on. A variable lookup will thus be recursively delegated to the linked variable lists, until a match is found. When modifying a variable which is not yet local, the program creates a local copy and uses this afterwards. Thus, when the local [[rt_data_t]] object is deleted, the context value is recovered. Models are kept in a model list which is separate from the variable list. Otherwise, they are treated in a similar manner: the local list is linked to the context model list. Model lookup is thus recursively delegated. When a model or any part of it is modified, the model is copied to the local [[rt_data_t]] object, so the context model is not modified. Commands such as [[integrate]] will create their own copy of the current model (and of the current variable list) at the point where they are executed. When a model is encountered for the first time, it is read from file. The reading is automatically delegated to the global context. Thus, this master copy survives until the main [[rt_data_t]] object is deleted, at program completion. If there is a currently active model, its variable list is linked to the main variable list. Variable lookups will then start from the model variable list. When the current model is switched, the new active model will get this link instead. Consequently, a change to the current model is kept as long as this model has a local copy; it survives local model switches. On the other hand, a parameter change in the current model doesn't affect any other model, even if the parameter name is identical. @ \subsection{Container for parse nodes} The runtime data set contains a bunch of parse nodes (chunks of code that have not been compiled into evaluation trees but saved for later use). We collect them here. This implementation has the useful effect that an assignment between two objects of this type will establish a pointer-target relationship for all components. <>= type :: rt_parse_nodes_t type(parse_node_t), pointer :: cuts_lexpr => null () type(parse_node_t), pointer :: scale_expr => null () type(parse_node_t), pointer :: fac_scale_expr => null () type(parse_node_t), pointer :: ren_scale_expr => null () type(parse_node_t), pointer :: weight_expr => null () type(parse_node_t), pointer :: selection_lexpr => null () type(parse_node_t), pointer :: reweight_expr => null () type(parse_node_t), pointer :: analysis_lexpr => null () type(parse_node_p), dimension(:), allocatable :: alt_setup contains <> end type rt_parse_nodes_t @ %def rt_parse_nodes_t @ Clear individual components. The parse nodes are nullified. No finalization needed since the pointer targets are part of the global parse tree. <>= procedure :: clear => rt_parse_nodes_clear <>= subroutine rt_parse_nodes_clear (rt_pn, name) class(rt_parse_nodes_t), intent(inout) :: rt_pn type(string_t), intent(in) :: name select case (char (name)) case ("cuts") rt_pn%cuts_lexpr => null () case ("scale") rt_pn%scale_expr => null () case ("factorization_scale") rt_pn%fac_scale_expr => null () case ("renormalization_scale") rt_pn%ren_scale_expr => null () case ("weight") rt_pn%weight_expr => null () case ("selection") rt_pn%selection_lexpr => null () case ("reweight") rt_pn%reweight_expr => null () case ("analysis") rt_pn%analysis_lexpr => null () end select end subroutine rt_parse_nodes_clear @ %def rt_parse_nodes_clear @ Output for the parse nodes. <>= procedure :: write => rt_parse_nodes_write <>= subroutine rt_parse_nodes_write (object, unit) class(rt_parse_nodes_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) call wrt ("Cuts", object%cuts_lexpr) call write_separator (u) call wrt ("Scale", object%scale_expr) call write_separator (u) call wrt ("Factorization scale", object%fac_scale_expr) call write_separator (u) call wrt ("Renormalization scale", object%ren_scale_expr) call write_separator (u) call wrt ("Weight", object%weight_expr) call write_separator (u, 2) call wrt ("Event selection", object%selection_lexpr) call write_separator (u) call wrt ("Event reweighting factor", object%reweight_expr) call write_separator (u) call wrt ("Event analysis", object%analysis_lexpr) if (allocated (object%alt_setup)) then call write_separator (u, 2) write (u, "(1x,A,':')") "Alternative setups" do i = 1, size (object%alt_setup) call write_separator (u) call wrt ("Commands", object%alt_setup(i)%ptr) end do end if contains subroutine wrt (title, pn) character(*), intent(in) :: title type(parse_node_t), intent(in), pointer :: pn if (associated (pn)) then write (u, "(1x,A,':')") title call write_separator (u) call parse_node_write_rec (pn, u) else write (u, "(1x,A,':',1x,A)") title, "[undefined]" end if end subroutine wrt end subroutine rt_parse_nodes_write @ %def rt_parse_nodes_write @ Screen output for individual components. (This should eventually be more condensed, currently we print the internal representation tree.) <>= procedure :: show => rt_parse_nodes_show <>= subroutine rt_parse_nodes_show (rt_pn, name, unit) class(rt_parse_nodes_t), intent(in) :: rt_pn type(string_t), intent(in) :: name integer, intent(in), optional :: unit type(parse_node_t), pointer :: pn integer :: u u = given_output_unit (unit) select case (char (name)) case ("cuts") pn => rt_pn%cuts_lexpr case ("scale") pn => rt_pn%scale_expr case ("factorization_scale") pn => rt_pn%fac_scale_expr case ("renormalization_scale") pn => rt_pn%ren_scale_expr case ("weight") pn => rt_pn%weight_expr case ("selection") pn => rt_pn%selection_lexpr case ("reweight") pn => rt_pn%reweight_expr case ("analysis") pn => rt_pn%analysis_lexpr end select if (associated (pn)) then write (u, "(A,1x,A,1x,A)") "Expression:", char (name), "(parse tree):" call parse_node_write_rec (pn, u) else write (u, "(A,1x,A,A)") "Expression:", char (name), ": [undefined]" end if end subroutine rt_parse_nodes_show @ %def rt_parse_nodes_show @ \subsection{The data type} This is a big data container which contains everything that is used and modified during the command flow. A local copy of this can be used to temporarily override defaults. The data set is transparent. <>= public :: rt_data_t <>= type :: rt_data_t type(lexer_t), pointer :: lexer => null () type(rt_data_t), pointer :: context => null () type(string_t), dimension(:), allocatable :: export type(var_list_t) :: var_list type(iterations_list_t) :: it_list type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model => null () logical :: model_is_copy = .false. type(model_t), pointer :: preload_model => null () type(model_t), pointer :: fallback_model => null () type(prclib_stack_t) :: prclib_stack type(process_library_t), pointer :: prclib => null () type(beam_structure_t) :: beam_structure type(rt_parse_nodes_t) :: pn type(process_stack_t) :: process_stack type(string_t), dimension(:), allocatable :: sample_fmt class(event_callback_t), allocatable :: event_callback type(file_list_t), pointer :: out_files => null () logical :: quit = .false. integer :: quit_code = 0 type(string_t) :: logfile logical :: nlo_fixed_order = .false. logical, dimension(0:5) :: selected_nlo_parts = .false. integer, dimension(:), allocatable :: nlo_component contains <> end type rt_data_t @ %def rt_data_t @ \subsection{Output} <>= procedure :: write => rt_data_write <>= subroutine rt_data_write (object, unit, vars, pacify) class(rt_data_t), intent(in) :: object integer, intent(in), optional :: unit type(string_t), dimension(:), intent(in), optional :: vars logical, intent(in), optional :: pacify integer :: u, i u = given_output_unit (unit) call write_separator (u, 2) write (u, "(1x,A)") "Runtime data:" if (object%get_n_export () > 0) then call write_separator (u, 2) write (u, "(1x,A)") "Exported objects and variables:" call write_separator (u) call object%write_exports (u) end if if (present (vars)) then if (size (vars) /= 0) then call write_separator (u, 2) write (u, "(1x,A)") "Selected variables:" call write_separator (u) call object%write_vars (u, vars) end if else call write_separator (u, 2) if (associated (object%model)) then call object%model%write_var_list (u, follow_link=.true.) else call object%var_list%write (u, follow_link=.true.) end if end if if (object%it_list%get_n_pass () > 0) then call write_separator (u, 2) write (u, "(1x)", advance="no") call object%it_list%write (u) end if if (associated (object%model)) then call write_separator (u, 2) call object%model%write (u) end if call object%prclib_stack%write (u) call object%beam_structure%write (u) call write_separator (u, 2) call object%pn%write (u) if (allocated (object%sample_fmt)) then call write_separator (u) write (u, "(1x,A)", advance="no") "Event sample formats = " do i = 1, size (object%sample_fmt) if (i > 1) write (u, "(A,1x)", advance="no") "," write (u, "(A)", advance="no") char (object%sample_fmt(i)) end do write (u, "(A)") end if call write_separator (u) write (u, "(1x,A)", advance="no") "Event callback:" if (allocated (object%event_callback)) then call object%event_callback%write (u) else write (u, "(1x,A)") "[undefined]" end if call object%process_stack%write (u, pacify) write (u, "(1x,A,1x,L1)") "quit :", object%quit write (u, "(1x,A,1x,I0)") "quit_code:", object%quit_code call write_separator (u, 2) write (u, "(1x,A,1x,A)") "Logfile :", "'" // trim (char (object%logfile)) // "'" call write_separator (u, 2) end subroutine rt_data_write @ %def rt_data_write @ Write only selected variables. <>= procedure :: write_vars => rt_data_write_vars <>= subroutine rt_data_write_vars (object, unit, vars) class(rt_data_t), intent(in), target :: object integer, intent(in), optional :: unit type(string_t), dimension(:), intent(in) :: vars type(var_list_t), pointer :: var_list integer :: u, i u = given_output_unit (unit) var_list => object%get_var_list_ptr () do i = 1, size (vars) associate (var => vars(i)) if (var_list%contains (var, follow_link=.true.)) then call var_list%write_var (var, unit = u, & follow_link = .true., defined=.true.) end if end associate end do end subroutine rt_data_write_vars @ %def rt_data_write_vars @ Write only the model list. <>= procedure :: write_model_list => rt_data_write_model_list <>= subroutine rt_data_write_model_list (object, unit) class(rt_data_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) call object%model_list%write (u) end subroutine rt_data_write_model_list @ %def rt_data_write_model_list @ Write only the library stack. <>= procedure :: write_libraries => rt_data_write_libraries <>= subroutine rt_data_write_libraries (object, unit, libpath) class(rt_data_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: libpath integer :: u u = given_output_unit (unit) call object%prclib_stack%write (u, libpath) end subroutine rt_data_write_libraries @ %def rt_data_write_libraries @ Write only the beam data. <>= procedure :: write_beams => rt_data_write_beams <>= subroutine rt_data_write_beams (object, unit) class(rt_data_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) call write_separator (u, 2) call object%beam_structure%write (u) call write_separator (u, 2) end subroutine rt_data_write_beams @ %def rt_data_write_beams @ Write only the process and event expressions. <>= procedure :: write_expr => rt_data_write_expr <>= subroutine rt_data_write_expr (object, unit) class(rt_data_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) call write_separator (u, 2) call object%pn%write (u) call write_separator (u, 2) end subroutine rt_data_write_expr @ %def rt_data_write_expr @ Write only the process stack. <>= procedure :: write_process_stack => rt_data_write_process_stack <>= subroutine rt_data_write_process_stack (object, unit) class(rt_data_t), intent(in) :: object integer, intent(in), optional :: unit call object%process_stack%write (unit) end subroutine rt_data_write_process_stack @ %def rt_data_write_process_stack @ <>= procedure :: write_var_descriptions => rt_data_write_var_descriptions <>= subroutine rt_data_write_var_descriptions (rt_data, unit, ascii_output) class(rt_data_t), intent(in) :: rt_data integer, intent(in), optional :: unit logical, intent(in), optional :: ascii_output integer :: u logical :: ao u = given_output_unit (unit) ao = .false.; if (present (ascii_output)) ao = ascii_output call rt_data%var_list%write (u, follow_link=.true., & descriptions=.true., ascii_output=ao) end subroutine rt_data_write_var_descriptions @ %def rt_data_write_var_descriptions @ <>= procedure :: show_description_of_string => rt_data_show_description_of_string <>= subroutine rt_data_show_description_of_string (rt_data, string, & unit, ascii_output) class(rt_data_t), intent(in) :: rt_data type(string_t), intent(in) :: string integer, intent(in), optional :: unit logical, intent(in), optional :: ascii_output integer :: u logical :: ao u = given_output_unit (unit) ao = .false.; if (present (ascii_output)) ao = ascii_output call rt_data%var_list%write_var (string, unit=u, follow_link=.true., & defined=.false., descriptions=.true., ascii_output=ao) end subroutine rt_data_show_description_of_string @ %def rt_data_show_description_of_string @ \subsection{Clear} The [[clear]] command can remove the contents of various subobjects. The objects themselves should stay. <>= procedure :: clear_beams => rt_data_clear_beams <>= subroutine rt_data_clear_beams (global) class(rt_data_t), intent(inout) :: global call global%beam_structure%final_sf () call global%beam_structure%final_pol () call global%beam_structure%final_mom () end subroutine rt_data_clear_beams @ %def rt_data_clear_beams @ \subsection{Initialization} Initialize runtime data. This defines special variables such as [[sqrts]], and should be done only for the instance that is actually global. Local copies will inherit the special variables. We link the global variable list to the process stack variable list, so the latter is always available (and kept global). <>= procedure :: global_init => rt_data_global_init <>= subroutine rt_data_global_init (global, paths, logfile) class(rt_data_t), intent(out), target :: global type(paths_t), intent(in), optional :: paths type(string_t), intent(in), optional :: logfile integer :: seed call global%os_data%init (paths) if (present (logfile)) then global%logfile = logfile else global%logfile = "" end if allocate (global%out_files) call system_clock (seed) call global%var_list%init_defaults (seed, paths) call global%init_pointer_variables () call global%process_stack%init_var_list (global%var_list) end subroutine rt_data_global_init @ %def rt_data_global_init @ \subsection{Local copies} This is done at compile time when a local copy of runtime data is needed: Link the variable list and initialize all derived parameters. This allows for synchronizing them with local variable changes without affecting global data. Also re-initialize pointer variables, so they point to local copies of their targets. <>= procedure :: local_init => rt_data_local_init <>= subroutine rt_data_local_init (local, global, env) class(rt_data_t), intent(inout), target :: local type(rt_data_t), intent(in), target :: global integer, intent(in), optional :: env local%context => global call local%process_stack%link (global%process_stack) call local%process_stack%init_var_list (local%var_list) call local%process_stack%link_var_list (global%var_list) call local%var_list%append_string (var_str ("$model_name"), & var_str (""), intrinsic=.true.) call local%init_pointer_variables () local%fallback_model => global%fallback_model local%os_data = global%os_data local%logfile = global%logfile call local%model_list%link (global%model_list) local%model => global%model if (associated (local%model)) then call local%model%link_var_list (local%var_list) end if if (allocated (global%event_callback)) then allocate (local%event_callback, source = global%event_callback) end if end subroutine rt_data_local_init @ %def rt_data_local_init @ These variables point to objects which get local copies: <>= procedure :: init_pointer_variables => rt_data_init_pointer_variables <>= subroutine rt_data_init_pointer_variables (local) class(rt_data_t), intent(inout), target :: local logical, target, save :: known = .true. call local%var_list%append_string_ptr (var_str ("$fc"), & local%os_data%fc, known, intrinsic=.true., & description=var_str('This string variable gives the ' // & '\ttt{Fortran} compiler used within \whizard. It can ' // & 'only be accessed, not set by the user. (cf. also ' // & '\ttt{\$fcflags})')) call local%var_list%append_string_ptr (var_str ("$fcflags"), & local%os_data%fcflags, known, intrinsic=.true., & description=var_str('This string variable gives the ' // & 'compiler flags for the \ttt{Fortran} compiler used ' // & 'within \whizard. It can only be accessed, not set by ' // & 'the user. (cf. also \ttt{\$fc})')) end subroutine rt_data_init_pointer_variables @ %def rt_data_init_pointer_variables @ This is done at execution time: Copy data, transfer pointers. [[local]] has intent(inout) because its local variable list has already been prepared by the previous routine. To be pedantic, the local pointers to model and library should point to the entries in the local copies. (However, as long as these are just shallow copies with identical content, this is actually irrelevant.) The process library and process stacks behave as global objects. The copies of the process library and process stacks should be shallow copies, so the contents stay identical. Since objects may be pushed on the stack in the local environment, upon restoring the global environment, we should reverse the assignment. Then the added stack elements will end up on the global stack. (This should be reconsidered in a parallel environment.) <>= procedure :: activate => rt_data_activate <>= subroutine rt_data_activate (local) class(rt_data_t), intent(inout), target :: local class(rt_data_t), pointer :: global global => local%context if (associated (global)) then local%lexer => global%lexer call global%copy_globals (local) local%os_data = global%os_data local%logfile = global%logfile if (associated (global%prclib)) then local%prclib => & local%prclib_stack%get_library_ptr (global%prclib%get_name ()) end if call local%import_values () call local%process_stack%link (global%process_stack) local%it_list = global%it_list local%beam_structure = global%beam_structure local%pn = global%pn if (allocated (local%sample_fmt)) deallocate (local%sample_fmt) if (allocated (global%sample_fmt)) then allocate (local%sample_fmt (size (global%sample_fmt)), & source = global%sample_fmt) end if local%out_files => global%out_files local%model => global%model local%model_is_copy = .false. else if (.not. associated (local%model)) then local%model => local%preload_model local%model_is_copy = .false. end if if (associated (local%model)) then call local%model%link_var_list (local%var_list) call local%var_list%set_string (var_str ("$model_name"), & local%model%get_name (), is_known = .true.) else call local%var_list%set_string (var_str ("$model_name"), & var_str (""), is_known = .false.) end if end subroutine rt_data_activate @ %def rt_data_activate @ Restore the previous state of data, without actually finalizing the local environment. We also clear the local process stack. Some local modifications (model list and process library stack) are communicated to the global context, if there is any. If the [[keep_local]] flag is set, we want to retain current settings in the local environment. In particular, we create an instance of the currently selected model (which thus becomes separated from the model library!). The local variables are also kept. <>= procedure :: deactivate => rt_data_deactivate <>= subroutine rt_data_deactivate (local, global, keep_local) class(rt_data_t), intent(inout), target :: local class(rt_data_t), intent(inout), optional, target :: global logical, intent(in), optional :: keep_local type(string_t) :: local_model, local_scheme logical :: same_model, delete delete = .true.; if (present (keep_local)) delete = .not. keep_local if (present (global)) then if (associated (global%model) .and. associated (local%model)) then local_model = local%model%get_name () if (global%model%has_schemes ()) then local_scheme = local%model%get_scheme () same_model = & global%model%matches (local_model, local_scheme) else same_model = global%model%matches (local_model) end if else same_model = .false. end if if (delete) then call local%process_stack%clear () call local%unselect_model () call local%unset_values () else if (associated (local%model)) then call local%ensure_model_copy () end if if (.not. same_model .and. associated (global%model)) then if (global%model%has_schemes ()) then call msg_message ("Restoring model '" // & char (global%model%get_name ()) // "', scheme '" // & char (global%model%get_scheme ()) // "'") else call msg_message ("Restoring model '" // & char (global%model%get_name ()) // "'") end if end if if (associated (global%model)) then call global%model%link_var_list (global%var_list) end if call global%restore_globals (local) else call local%unselect_model () end if end subroutine rt_data_deactivate @ %def rt_data_deactivate @ This imports the global objects for which local modifications should be kept. Currently, this is only the process library stack. <>= procedure :: copy_globals => rt_data_copy_globals <>= subroutine rt_data_copy_globals (global, local) class(rt_data_t), intent(in) :: global class(rt_data_t), intent(inout) :: local local%prclib_stack = global%prclib_stack end subroutine rt_data_copy_globals @ %def rt_data_copy_globals @ This restores global objects for which local modifications should be kept. May also modify (remove) the local objects. <>= procedure :: restore_globals => rt_data_restore_globals <>= subroutine rt_data_restore_globals (global, local) class(rt_data_t), intent(inout) :: global class(rt_data_t), intent(inout) :: local global%prclib_stack = local%prclib_stack call local%handle_exports (global) end subroutine rt_data_restore_globals @ %def rt_data_restore_globals @ \subsection{Exported objects} Exported objects are transferred to the global state when a local environment is closed. (For the top-level global data set, there is no effect.) The current implementation handles only the [[results]] object, which resolves to the local process stack. The stack elements are appended to the global stack without modification, the local stack becomes empty. Write names of objects to be exported: <>= procedure :: write_exports => rt_data_write_exports <>= subroutine rt_data_write_exports (rt_data, unit) class(rt_data_t), intent(in) :: rt_data integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) do i = 1, rt_data%get_n_export () write (u, "(A)") char (rt_data%export(i)) end do end subroutine rt_data_write_exports @ %def rt_data_write_exports @ The number of entries in the export list. <>= procedure :: get_n_export => rt_data_get_n_export <>= function rt_data_get_n_export (rt_data) result (n) class(rt_data_t), intent(in) :: rt_data integer :: n if (allocated (rt_data%export)) then n = size (rt_data%export) else n = 0 end if end function rt_data_get_n_export @ %def rt_data_get_n_export @ Return a specific export @ Append new names to the export list. If a duplicate occurs, do not transfer it. <>= procedure :: append_exports => rt_data_append_exports <>= subroutine rt_data_append_exports (rt_data, export) class(rt_data_t), intent(inout) :: rt_data type(string_t), dimension(:), intent(in) :: export logical, dimension(:), allocatable :: mask type(string_t), dimension(:), allocatable :: tmp integer :: i, j, n if (.not. allocated (rt_data%export)) allocate (rt_data%export (0)) n = size (rt_data%export) allocate (mask (size (export)), source=.false.) do i = 1, size (export) mask(i) = all (export(i) /= rt_data%export) & .and. all (export(i) /= export(:i-1)) end do if (count (mask) > 0) then allocate (tmp (n + count (mask))) tmp(1:n) = rt_data%export(:) j = n do i = 1, size (export) if (mask(i)) then j = j + 1 tmp(j) = export(i) end if end do call move_alloc (from=tmp, to=rt_data%export) end if end subroutine rt_data_append_exports @ %def rt_data_append_exports @ Transfer export-objects from the [[local]] rt data to the [[global]] rt data, as far as supported. <>= procedure :: handle_exports => rt_data_handle_exports <>= subroutine rt_data_handle_exports (local, global) class(rt_data_t), intent(inout), target :: local class(rt_data_t), intent(inout), target :: global type(string_t) :: export integer :: i if (local%get_n_export () > 0) then do i = 1, local%get_n_export () export = local%export(i) select case (char (export)) case ("results") call msg_message ("Exporting integration results & &to outer environment") call local%transfer_process_stack (global) case default call msg_bug ("handle exports: '" & // char (export) // "' unsupported") end select end do end if end subroutine rt_data_handle_exports @ %def rt_data_handle_exports @ Export the process stack. One-by-one, take the last process from the local stack and push it on the global stack. Also handle the corresponding result variables: append if the process did not exist yet in the global stack, otherwise update. TODO: result variables don't work that way yet, require initialization in the global variable list. <>= procedure :: transfer_process_stack => rt_data_transfer_process_stack <>= subroutine rt_data_transfer_process_stack (local, global) class(rt_data_t), intent(inout), target :: local class(rt_data_t), intent(inout), target :: global type(process_entry_t), pointer :: process type(string_t) :: process_id do call local%process_stack%pop_last (process) if (.not. associated (process)) exit process_id = process%get_id () call global%process_stack%push (process) call global%process_stack%fill_result_vars (process_id) call global%process_stack%update_result_vars & (process_id, global%var_list) end do end subroutine rt_data_transfer_process_stack @ %def rt_data_transfer_process_stack @ \subsection{Finalization} Finalizer for the variable list and the structure-function list. This is done only for the global RT dataset; local copies contain pointers to this and do not need a finalizer. <>= procedure :: final => rt_data_global_final <>= subroutine rt_data_global_final (global) class(rt_data_t), intent(inout) :: global call global%process_stack%final () call global%prclib_stack%final () call global%model_list%final () call global%var_list%final (follow_link=.false.) if (associated (global%out_files)) then call file_list_final (global%out_files) deallocate (global%out_files) end if end subroutine rt_data_global_final @ %def rt_data_global_final @ The local copy needs a finalizer for the variable list, which consists of local copies. This finalizer is called only when the local environment is finally discarded. (Note that the process stack should already have been cleared after execution, which can occur many times for the same local environment.) <>= procedure :: local_final => rt_data_local_final <>= subroutine rt_data_local_final (local) class(rt_data_t), intent(inout) :: local call local%process_stack%clear () call local%model_list%final () call local%var_list%final (follow_link=.false.) end subroutine rt_data_local_final @ %def rt_data_local_final @ \subsection{Model Management} Read a model, so it becomes available for activation. No variables or model copies, this is just initialization. If this is a local environment, the model will be automatically read into the global context. <>= procedure :: read_model => rt_data_read_model <>= subroutine rt_data_read_model (global, name, model, scheme) class(rt_data_t), intent(inout) :: global type(string_t), intent(in) :: name type(string_t), intent(in), optional :: scheme type(model_t), pointer, intent(out) :: model type(string_t) :: filename filename = name // ".mdl" call global%model_list%read_model & (name, filename, global%os_data, model, scheme) end subroutine rt_data_read_model @ %def rt_data_read_model @ Read a UFO model. Create it on the fly if necessary. <>= procedure :: read_ufo_model => rt_data_read_ufo_model <>= subroutine rt_data_read_ufo_model (global, name, model, ufo_path) class(rt_data_t), intent(inout) :: global type(string_t), intent(in) :: name type(model_t), pointer, intent(out) :: model type(string_t), intent(in), optional :: ufo_path type(string_t) :: filename filename = name // ".ufo.mdl" call global%model_list%read_model & (name, filename, global%os_data, model, ufo=.true., ufo_path=ufo_path) end subroutine rt_data_read_ufo_model @ %def rt_data_read_ufo_model @ Initialize the fallback model. This model is used whenever the current model does not describe all physical particles (hadrons, mainly). It is not supposed to be modified, and the pointer should remain linked to this model. <>= procedure :: init_fallback_model => rt_data_init_fallback_model <>= subroutine rt_data_init_fallback_model (global, name, filename) class(rt_data_t), intent(inout) :: global type(string_t), intent(in) :: name, filename call global%model_list%read_model & (name, filename, global%os_data, global%fallback_model) end subroutine rt_data_init_fallback_model @ %def rt_data_init_fallback_model @ Activate a model: assign the current-model pointer and set the model name in the variable list. If necessary, read the model from file. Link the global variable list to the model variable list. <>= procedure :: select_model => rt_data_select_model <>= subroutine rt_data_select_model (global, name, scheme, ufo, ufo_path) class(rt_data_t), intent(inout), target :: global type(string_t), intent(in) :: name type(string_t), intent(in), optional :: scheme logical, intent(in), optional :: ufo type(string_t), intent(in), optional :: ufo_path logical :: same_model, ufo_model ufo_model = .false.; if (present (ufo)) ufo_model = ufo if (associated (global%model)) then same_model = global%model%matches (name, scheme, ufo) else same_model = .false. end if if (.not. same_model) then global%model => global%model_list%get_model_ptr (name, scheme, ufo) if (.not. associated (global%model)) then if (ufo_model) then call global%read_ufo_model (name, global%model, ufo_path) else call global%read_model (name, global%model) end if global%model_is_copy = .false. else if (associated (global%context)) then global%model_is_copy = & global%model_list%model_exists (name, scheme, ufo, & follow_link=.false.) else global%model_is_copy = .false. end if end if if (associated (global%model)) then call global%model%link_var_list (global%var_list) call global%var_list%set_string (var_str ("$model_name"), & name, is_known = .true.) if (global%model%is_ufo_model ()) then call msg_message ("Switching to model '" // char (name) // "' " & // "(generated from UFO source)") else if (global%model%has_schemes ()) then call msg_message ("Switching to model '" // char (name) // "', " & // "scheme '" // char (global%model%get_scheme ()) // "'") else call msg_message ("Switching to model '" // char (name) // "'") end if else call global%var_list%set_string (var_str ("$model_name"), & var_str (""), is_known = .false.) end if end subroutine rt_data_select_model @ %def rt_data_select_model @ -Remove the model link and unset the model name variable. +Remove the model link. Do not unset the model name variable, because +this may unset the variable in a parent [[rt_data]] object (via linked +var lists). <>= procedure :: unselect_model => rt_data_unselect_model <>= subroutine rt_data_unselect_model (global) class(rt_data_t), intent(inout), target :: global if (associated (global%model)) then global%model => null () global%model_is_copy = .false. - call global%var_list%set_string (var_str ("$model_name"), & - var_str (""), is_known = .false.) end if end subroutine rt_data_unselect_model @ %def rt_data_unselect_model @ Create a copy of the currently selected model and append it to the local model list. The model pointer is redirected to the copy. (Not applicable for the global model list, those models will be modified in-place.) <>= procedure :: ensure_model_copy => rt_data_ensure_model_copy <>= subroutine rt_data_ensure_model_copy (global) class(rt_data_t), intent(inout), target :: global if (associated (global%context)) then if (.not. global%model_is_copy) then call global%model_list%append_copy (global%model, global%model) global%model_is_copy = .true. call global%model%link_var_list (global%var_list) end if end if end subroutine rt_data_ensure_model_copy @ %def rt_data_ensure_model_copy @ Modify a model variable. The update mechanism will ensure that the model parameter set remains consistent. This has to take place in a local copy of the current model. If there is none yet, create one. <>= procedure :: model_set_real => rt_data_model_set_real <>= subroutine rt_data_model_set_real (global, name, rval, verbose, pacified) class(rt_data_t), intent(inout), target :: global type(string_t), intent(in) :: name real(default), intent(in) :: rval logical, intent(in), optional :: verbose, pacified call global%ensure_model_copy () call global%model%set_real (name, rval, verbose, pacified) end subroutine rt_data_model_set_real @ %def rt_data_model_set_real @ Modify particle properties. This has to take place in a local copy of the current model. If there is none yet, create one. <>= procedure :: modify_particle => rt_data_modify_particle <>= subroutine rt_data_modify_particle & (global, pdg, polarized, stable, decay, & isotropic_decay, diagonal_decay, decay_helicity) class(rt_data_t), intent(inout), target :: global integer, intent(in) :: pdg logical, intent(in), optional :: polarized, stable logical, intent(in), optional :: isotropic_decay, diagonal_decay integer, intent(in), optional :: decay_helicity type(string_t), dimension(:), intent(in), optional :: decay call global%ensure_model_copy () if (present (polarized)) then if (polarized) then call global%model%set_polarized (pdg) else call global%model%set_unpolarized (pdg) end if end if if (present (stable)) then if (stable) then call global%model%set_stable (pdg) else if (present (decay)) then call global%model%set_unstable & (pdg, decay, isotropic_decay, diagonal_decay, decay_helicity) else call msg_bug ("Setting particle unstable: missing decay processes") end if end if end subroutine rt_data_modify_particle @ %def rt_data_modify_particle @ \subsection{Managing Variables} Return a pointer to the currently active variable list. If there is no model, this is the global variable list. If there is one, it is the model variable list, which should be linked to the former. <>= procedure :: get_var_list_ptr => rt_data_get_var_list_ptr <>= function rt_data_get_var_list_ptr (global) result (var_list) class(rt_data_t), intent(in), target :: global type(var_list_t), pointer :: var_list if (associated (global%model)) then var_list => global%model%get_var_list_ptr () else var_list => global%var_list end if end function rt_data_get_var_list_ptr @ %def rt_data_get_var_list_ptr @ Initialize a local variable: append it to the current variable list. No initial value, yet. <>= procedure :: append_log => rt_data_append_log procedure :: append_int => rt_data_append_int procedure :: append_real => rt_data_append_real procedure :: append_cmplx => rt_data_append_cmplx procedure :: append_subevt => rt_data_append_subevt procedure :: append_pdg_array => rt_data_append_pdg_array procedure :: append_string => rt_data_append_string <>= subroutine rt_data_append_log (local, name, lval, intrinsic, user) class(rt_data_t), intent(inout) :: local type(string_t), intent(in) :: name logical, intent(in), optional :: lval logical, intent(in), optional :: intrinsic, user call local%var_list%append_log (name, lval, & intrinsic = intrinsic, user = user) end subroutine rt_data_append_log subroutine rt_data_append_int (local, name, ival, intrinsic, user) class(rt_data_t), intent(inout) :: local type(string_t), intent(in) :: name integer, intent(in), optional :: ival logical, intent(in), optional :: intrinsic, user call local%var_list%append_int (name, ival, & intrinsic = intrinsic, user = user) end subroutine rt_data_append_int subroutine rt_data_append_real (local, name, rval, intrinsic, user) class(rt_data_t), intent(inout) :: local type(string_t), intent(in) :: name real(default), intent(in), optional :: rval logical, intent(in), optional :: intrinsic, user call local%var_list%append_real (name, rval, & intrinsic = intrinsic, user = user) end subroutine rt_data_append_real subroutine rt_data_append_cmplx (local, name, cval, intrinsic, user) class(rt_data_t), intent(inout) :: local type(string_t), intent(in) :: name complex(default), intent(in), optional :: cval logical, intent(in), optional :: intrinsic, user call local%var_list%append_cmplx (name, cval, & intrinsic = intrinsic, user = user) end subroutine rt_data_append_cmplx subroutine rt_data_append_subevt (local, name, pval, intrinsic, user) class(rt_data_t), intent(inout) :: local type(string_t), intent(in) :: name type(subevt_t), intent(in), optional :: pval logical, intent(in) :: intrinsic, user call local%var_list%append_subevt (name, & intrinsic = intrinsic, user = user) end subroutine rt_data_append_subevt subroutine rt_data_append_pdg_array (local, name, aval, intrinsic, user) class(rt_data_t), intent(inout) :: local type(string_t), intent(in) :: name type(pdg_array_t), intent(in), optional :: aval logical, intent(in), optional :: intrinsic, user call local%var_list%append_pdg_array (name, aval, & intrinsic = intrinsic, user = user) end subroutine rt_data_append_pdg_array subroutine rt_data_append_string (local, name, sval, intrinsic, user) class(rt_data_t), intent(inout) :: local type(string_t), intent(in) :: name type(string_t), intent(in), optional :: sval logical, intent(in), optional :: intrinsic, user call local%var_list%append_string (name, sval, & intrinsic = intrinsic, user = user) end subroutine rt_data_append_string @ %def rt_data_append_log @ %def rt_data_append_int @ %def rt_data_append_real @ %def rt_data_append_cmplx @ %def rt_data_append_subevt @ %def rt_data_append_pdg_array @ %def rt_data_append_string @ Import values for all local variables, given a global context environment where these variables are defined. <>= procedure :: import_values => rt_data_import_values <>= subroutine rt_data_import_values (local) class(rt_data_t), intent(inout) :: local type(rt_data_t), pointer :: global global => local%context if (associated (global)) then call local%var_list%import (global%var_list) end if end subroutine rt_data_import_values @ %def rt_data_import_values @ Unset all variable values. <>= procedure :: unset_values => rt_data_unset_values <>= subroutine rt_data_unset_values (global) class(rt_data_t), intent(inout) :: global call global%var_list%undefine (follow_link=.false.) end subroutine rt_data_unset_values @ %def rt_data_unset_values @ Set a variable. (Not a model variable, these are handled separately.) We can assume that the variable has been initialized. <>= procedure :: set_log => rt_data_set_log procedure :: set_int => rt_data_set_int procedure :: set_real => rt_data_set_real procedure :: set_cmplx => rt_data_set_cmplx procedure :: set_subevt => rt_data_set_subevt procedure :: set_pdg_array => rt_data_set_pdg_array procedure :: set_string => rt_data_set_string <>= subroutine rt_data_set_log & (global, name, lval, is_known, force, verbose) class(rt_data_t), intent(inout) :: global type(string_t), intent(in) :: name logical, intent(in) :: lval logical, intent(in) :: is_known logical, intent(in), optional :: force, verbose call global%var_list%set_log (name, lval, is_known, & force=force, verbose=verbose) end subroutine rt_data_set_log subroutine rt_data_set_int & (global, name, ival, is_known, force, verbose) class(rt_data_t), intent(inout) :: global type(string_t), intent(in) :: name integer, intent(in) :: ival logical, intent(in) :: is_known logical, intent(in), optional :: force, verbose call global%var_list%set_int (name, ival, is_known, & force=force, verbose=verbose) end subroutine rt_data_set_int subroutine rt_data_set_real & (global, name, rval, is_known, force, verbose, pacified) class(rt_data_t), intent(inout) :: global type(string_t), intent(in) :: name real(default), intent(in) :: rval logical, intent(in) :: is_known logical, intent(in), optional :: force, verbose, pacified call global%var_list%set_real (name, rval, is_known, & force=force, verbose=verbose, pacified=pacified) end subroutine rt_data_set_real subroutine rt_data_set_cmplx & (global, name, cval, is_known, force, verbose, pacified) class(rt_data_t), intent(inout) :: global type(string_t), intent(in) :: name complex(default), intent(in) :: cval logical, intent(in) :: is_known logical, intent(in), optional :: force, verbose, pacified call global%var_list%set_cmplx (name, cval, is_known, & force=force, verbose=verbose, pacified=pacified) end subroutine rt_data_set_cmplx subroutine rt_data_set_subevt & (global, name, pval, is_known, force, verbose) class(rt_data_t), intent(inout) :: global type(string_t), intent(in) :: name type(subevt_t), intent(in) :: pval logical, intent(in) :: is_known logical, intent(in), optional :: force, verbose call global%var_list%set_subevt (name, pval, is_known, & force=force, verbose=verbose) end subroutine rt_data_set_subevt subroutine rt_data_set_pdg_array & (global, name, aval, is_known, force, verbose) class(rt_data_t), intent(inout) :: global type(string_t), intent(in) :: name type(pdg_array_t), intent(in) :: aval logical, intent(in) :: is_known logical, intent(in), optional :: force, verbose call global%var_list%set_pdg_array (name, aval, is_known, & force=force, verbose=verbose) end subroutine rt_data_set_pdg_array subroutine rt_data_set_string & (global, name, sval, is_known, force, verbose) class(rt_data_t), intent(inout) :: global type(string_t), intent(in) :: name type(string_t), intent(in) :: sval logical, intent(in) :: is_known logical, intent(in), optional :: force, verbose call global%var_list%set_string (name, sval, is_known, & force=force, verbose=verbose) end subroutine rt_data_set_string @ %def rt_data_set_log @ %def rt_data_set_int @ %def rt_data_set_real @ %def rt_data_set_cmplx @ %def rt_data_set_subevt @ %def rt_data_set_pdg_array @ %def rt_data_set_string @ Return the value of a variable, assuming that the type is correct. <>= procedure :: get_lval => rt_data_get_lval procedure :: get_ival => rt_data_get_ival procedure :: get_rval => rt_data_get_rval procedure :: get_cval => rt_data_get_cval procedure :: get_pval => rt_data_get_pval procedure :: get_aval => rt_data_get_aval procedure :: get_sval => rt_data_get_sval <>= function rt_data_get_lval (global, name) result (lval) logical :: lval class(rt_data_t), intent(in), target :: global type(string_t), intent(in) :: name type(var_list_t), pointer :: var_list var_list => global%get_var_list_ptr () lval = var_list%get_lval (name) end function rt_data_get_lval function rt_data_get_ival (global, name) result (ival) integer :: ival class(rt_data_t), intent(in), target :: global type(string_t), intent(in) :: name type(var_list_t), pointer :: var_list var_list => global%get_var_list_ptr () ival = var_list%get_ival (name) end function rt_data_get_ival function rt_data_get_rval (global, name) result (rval) real(default) :: rval class(rt_data_t), intent(in), target :: global type(string_t), intent(in) :: name type(var_list_t), pointer :: var_list var_list => global%get_var_list_ptr () rval = var_list%get_rval (name) end function rt_data_get_rval function rt_data_get_cval (global, name) result (cval) complex(default) :: cval class(rt_data_t), intent(in), target :: global type(string_t), intent(in) :: name type(var_list_t), pointer :: var_list var_list => global%get_var_list_ptr () cval = var_list%get_cval (name) end function rt_data_get_cval function rt_data_get_aval (global, name) result (aval) type(pdg_array_t) :: aval class(rt_data_t), intent(in), target :: global type(string_t), intent(in) :: name type(var_list_t), pointer :: var_list var_list => global%get_var_list_ptr () aval = var_list%get_aval (name) end function rt_data_get_aval function rt_data_get_pval (global, name) result (pval) type(subevt_t) :: pval class(rt_data_t), intent(in), target :: global type(string_t), intent(in) :: name type(var_list_t), pointer :: var_list var_list => global%get_var_list_ptr () pval = var_list%get_pval (name) end function rt_data_get_pval function rt_data_get_sval (global, name) result (sval) type(string_t) :: sval class(rt_data_t), intent(in), target :: global type(string_t), intent(in) :: name type(var_list_t), pointer :: var_list var_list => global%get_var_list_ptr () sval = var_list%get_sval (name) end function rt_data_get_sval @ %def rt_data_get_lval @ %def rt_data_get_ival @ %def rt_data_get_rval @ %def rt_data_get_cval @ %def rt_data_get_pval @ %def rt_data_get_aval @ %def rt_data_get_sval @ Return true if the variable exists in the global list. <>= procedure :: contains => rt_data_contains <>= function rt_data_contains (global, name) result (lval) logical :: lval class(rt_data_t), intent(in) :: global type(string_t), intent(in) :: name type(var_list_t), pointer :: var_list var_list => global%get_var_list_ptr () lval = var_list%contains (name) end function rt_data_contains @ %def rt_data_contains @ \subsection{Further Content} Add a library (available via a pointer of type [[prclib_entry_t]]) to the stack and update the pointer and variable list to the current library. The pointer association of [[prclib_entry]] will be discarded. <>= procedure :: add_prclib => rt_data_add_prclib <>= subroutine rt_data_add_prclib (global, prclib_entry) class(rt_data_t), intent(inout) :: global type(prclib_entry_t), intent(inout), pointer :: prclib_entry call global%prclib_stack%push (prclib_entry) call global%update_prclib (global%prclib_stack%get_first_ptr ()) end subroutine rt_data_add_prclib @ %def rt_data_add_prclib @ Given a pointer to a process library, make this the currently active library. <>= procedure :: update_prclib => rt_data_update_prclib <>= subroutine rt_data_update_prclib (global, lib) class(rt_data_t), intent(inout) :: global type(process_library_t), intent(in), target :: lib global%prclib => lib if (global%var_list%contains (& var_str ("$library_name"), follow_link = .false.)) then call global%var_list%set_string (var_str ("$library_name"), & global%prclib%get_name (), is_known=.true.) else call global%var_list%append_string ( & var_str ("$library_name"), global%prclib%get_name (), & intrinsic = .true.) end if end subroutine rt_data_update_prclib @ %def rt_data_update_prclib @ \subsection{Miscellaneous} The helicity selection data are distributed among several parameters. Here, we collect them in a single record. <>= procedure :: get_helicity_selection => rt_data_get_helicity_selection <>= function rt_data_get_helicity_selection (rt_data) result (helicity_selection) class(rt_data_t), intent(in) :: rt_data type(helicity_selection_t) :: helicity_selection associate (var_list => rt_data%var_list) helicity_selection%active = var_list%get_lval (& var_str ("?helicity_selection_active")) if (helicity_selection%active) then helicity_selection%threshold = var_list%get_rval (& var_str ("helicity_selection_threshold")) helicity_selection%cutoff = var_list%get_ival (& var_str ("helicity_selection_cutoff")) end if end associate end function rt_data_get_helicity_selection @ %def rt_data_get_helicity_selection @ Show the beam setup: beam structure and relevant global variables. <>= procedure :: show_beams => rt_data_show_beams <>= subroutine rt_data_show_beams (rt_data, unit) class(rt_data_t), intent(in) :: rt_data integer, intent(in), optional :: unit type(string_t) :: s integer :: u u = given_output_unit (unit) associate (beams => rt_data%beam_structure, var_list => rt_data%var_list) call beams%write (u) if (.not. beams%asymmetric () .and. beams%get_n_beam () == 2) then write (u, "(2x,A," // FMT_19 // ",1x,'GeV')") "sqrts =", & var_list%get_rval (var_str ("sqrts")) end if if (beams%contains ("pdf_builtin")) then s = var_list%get_sval (var_str ("$pdf_builtin_set")) if (s /= "") then write (u, "(2x,A,1x,3A)") "PDF set =", '"', char (s), '"' else write (u, "(2x,A,1x,A)") "PDF set =", "[undefined]" end if end if if (beams%contains ("lhapdf")) then s = var_list%get_sval (var_str ("$lhapdf_dir")) if (s /= "") then write (u, "(2x,A,1x,3A)") "LHAPDF dir =", '"', char (s), '"' end if s = var_list%get_sval (var_str ("$lhapdf_file")) if (s /= "") then write (u, "(2x,A,1x,3A)") "LHAPDF file =", '"', char (s), '"' write (u, "(2x,A,1x,I0)") "LHAPDF member =", & var_list%get_ival (var_str ("lhapdf_member")) else write (u, "(2x,A,1x,A)") "LHAPDF file =", "[undefined]" end if end if if (beams%contains ("lhapdf_photon")) then s = var_list%get_sval (var_str ("$lhapdf_dir")) if (s /= "") then write (u, "(2x,A,1x,3A)") "LHAPDF dir =", '"', char (s), '"' end if s = var_list%get_sval (var_str ("$lhapdf_photon_file")) if (s /= "") then write (u, "(2x,A,1x,3A)") "LHAPDF file =", '"', char (s), '"' write (u, "(2x,A,1x,I0)") "LHAPDF member =", & var_list%get_ival (var_str ("lhapdf_member")) write (u, "(2x,A,1x,I0)") "LHAPDF scheme =", & var_list%get_ival (& var_str ("lhapdf_photon_scheme")) else write (u, "(2x,A,1x,A)") "LHAPDF file =", "[undefined]" end if end if if (beams%contains ("isr")) then write (u, "(2x,A," // FMT_19 // ")") "ISR alpha =", & var_list%get_rval (var_str ("isr_alpha")) write (u, "(2x,A," // FMT_19 // ")") "ISR Q max =", & var_list%get_rval (var_str ("isr_q_max")) write (u, "(2x,A," // FMT_19 // ")") "ISR mass =", & var_list%get_rval (var_str ("isr_mass")) write (u, "(2x,A,1x,I0)") "ISR order =", & var_list%get_ival (var_str ("isr_order")) write (u, "(2x,A,1x,L1)") "ISR recoil =", & var_list%get_lval (var_str ("?isr_recoil")) write (u, "(2x,A,1x,L1)") "ISR energy cons. =", & var_list%get_lval (var_str ("?isr_keep_energy")) end if if (beams%contains ("epa")) then write (u, "(2x,A," // FMT_19 // ")") "EPA alpha =", & var_list%get_rval (var_str ("epa_alpha")) write (u, "(2x,A," // FMT_19 // ")") "EPA x min =", & var_list%get_rval (var_str ("epa_x_min")) write (u, "(2x,A," // FMT_19 // ")") "EPA Q min =", & var_list%get_rval (var_str ("epa_q_min")) write (u, "(2x,A," // FMT_19 // ")") "EPA E max =", & var_list%get_rval (var_str ("epa_e_max")) write (u, "(2x,A," // FMT_19 // ")") "EPA mass =", & var_list%get_rval (var_str ("epa_mass")) write (u, "(2x,A,1x,L1)") "EPA recoil =", & var_list%get_lval (var_str ("?epa_recoil")) write (u, "(2x,A,1x,L1)") "EPA energy cons. =", & var_list%get_lval (var_str ("?epa_keep_energy")) end if if (beams%contains ("ewa")) then write (u, "(2x,A," // FMT_19 // ")") "EWA x min =", & var_list%get_rval (var_str ("ewa_x_min")) write (u, "(2x,A," // FMT_19 // ")") "EWA Pt max =", & var_list%get_rval (var_str ("ewa_pt_max")) write (u, "(2x,A," // FMT_19 // ")") "EWA mass =", & var_list%get_rval (var_str ("ewa_mass")) write (u, "(2x,A,1x,L1)") "EWA recoil =", & var_list%get_lval (var_str ("?ewa_recoil")) write (u, "(2x,A,1x,L1)") "EWA energy cons. =", & var_list%get_lval (var_str ("ewa_keep_energy")) end if if (beams%contains ("circe1")) then write (u, "(2x,A,1x,I0)") "CIRCE1 version =", & var_list%get_ival (var_str ("circe1_ver")) write (u, "(2x,A,1x,I0)") "CIRCE1 revision =", & var_list%get_ival (var_str ("circe1_rev")) s = var_list%get_sval (var_str ("$circe1_acc")) write (u, "(2x,A,1x,A)") "CIRCE1 acceler. =", char (s) write (u, "(2x,A,1x,I0)") "CIRCE1 chattin. =", & var_list%get_ival (var_str ("circe1_chat")) write (u, "(2x,A," // FMT_19 // ")") "CIRCE1 sqrts =", & var_list%get_rval (var_str ("circe1_sqrts")) write (u, "(2x,A," // FMT_19 // ")") "CIRCE1 epsil. =", & var_list%get_rval (var_str ("circe1_eps")) write (u, "(2x,A,1x,L1)") "CIRCE1 phot. 1 =", & var_list%get_lval (var_str ("?circe1_photon1")) write (u, "(2x,A,1x,L1)") "CIRCE1 phot. 2 =", & var_list%get_lval (var_str ("?circe1_photon2")) write (u, "(2x,A,1x,L1)") "CIRCE1 generat. =", & var_list%get_lval (var_str ("?circe1_generate")) write (u, "(2x,A,1x,L1)") "CIRCE1 mapping =", & var_list%get_lval (var_str ("?circe1_map")) write (u, "(2x,A," // FMT_19 // ")") "CIRCE1 map. slope =", & var_list%get_rval (var_str ("circe1_mapping_slope")) write (u, "(2x,A,1x,L1)") "CIRCE recoil photon =", & var_list%get_lval (var_str ("?circe1_with_radiation")) end if if (beams%contains ("circe2")) then s = var_list%get_sval (var_str ("$circe2_design")) write (u, "(2x,A,1x,A)") "CIRCE2 design =", char (s) s = var_list%get_sval (var_str ("$circe2_file")) write (u, "(2x,A,1x,A)") "CIRCE2 file =", char (s) write (u, "(2x,A,1x,L1)") "CIRCE2 polarized =", & var_list%get_lval (var_str ("?circe2_polarized")) end if if (beams%contains ("gaussian")) then write (u, "(2x,A,1x," // FMT_12 // ")") "Gaussian spread 1 =", & var_list%get_rval (var_str ("gaussian_spread1")) write (u, "(2x,A,1x," // FMT_12 // ")") "Gaussian spread 2 =", & var_list%get_rval (var_str ("gaussian_spread2")) end if if (beams%contains ("beam_events")) then s = var_list%get_sval (var_str ("$beam_events_file")) write (u, "(2x,A,1x,A)") "Beam events file =", char (s) write (u, "(2x,A,1x,L1)") "Beam events EOF warn =", & var_list%get_lval (var_str ("?beam_events_warn_eof")) end if end associate end subroutine rt_data_show_beams @ %def rt_data_show_beams @ Return the collision energy as determined by the current beam settings. Without beam setup, this is the [[sqrts]] variable. If the value is meaningless for a setup, the function returns zero. <>= procedure :: get_sqrts => rt_data_get_sqrts <>= function rt_data_get_sqrts (rt_data) result (sqrts) class(rt_data_t), intent(in) :: rt_data real(default) :: sqrts sqrts = rt_data%var_list%get_rval (var_str ("sqrts")) end function rt_data_get_sqrts @ %def rt_data_get_sqrts @ For testing purposes, the [[rt_data_t]] contents can be pacified to suppress numerical fluctuations in (constant) test matrix elements. <>= procedure :: pacify => rt_data_pacify <>= subroutine rt_data_pacify (rt_data, efficiency_reset, error_reset) class(rt_data_t), intent(inout) :: rt_data logical, intent(in), optional :: efficiency_reset, error_reset type(process_entry_t), pointer :: process process => rt_data%process_stack%first do while (associated (process)) call process%pacify (efficiency_reset, error_reset) process => process%next end do end subroutine rt_data_pacify @ %def rt_data_pacify @ <>= procedure :: set_event_callback => rt_data_set_event_callback <>= subroutine rt_data_set_event_callback (global, callback) class(rt_data_t), intent(inout) :: global class(event_callback_t), intent(in) :: callback if (allocated (global%event_callback)) deallocate (global%event_callback) allocate (global%event_callback, source = callback) end subroutine rt_data_set_event_callback @ %def rt_data_set_event_callback @ <>= procedure :: has_event_callback => rt_data_has_event_callback procedure :: get_event_callback => rt_data_get_event_callback <>= function rt_data_has_event_callback (global) result (flag) class(rt_data_t), intent(in) :: global logical :: flag flag = allocated (global%event_callback) end function rt_data_has_event_callback function rt_data_get_event_callback (global) result (callback) class(rt_data_t), intent(in) :: global class(event_callback_t), allocatable :: callback if (allocated (global%event_callback)) then allocate (callback, source = global%event_callback) end if end function rt_data_get_event_callback @ %def rt_data_has_event_callback @ %def rt_data_get_event_callback @ Force system-dependent objects to well-defined values. Some of the variables are locked and therefore must be addressed directly. This is, of course, only required for testing purposes. In principle, the [[real_specimen]] variables could be set to their values in [[rt_data_t]], but this depends on the precision again, so we set them to some dummy values. <>= public :: fix_system_dependencies <>= subroutine fix_system_dependencies (global) class(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list var_list => global%get_var_list_ptr () call var_list%set_log (var_str ("?omega_openmp"), & .false., is_known = .true., force=.true.) call var_list%set_log (var_str ("?openmp_is_active"), & .false., is_known = .true., force=.true.) call var_list%set_int (var_str ("openmp_num_threads_default"), & 1, is_known = .true., force=.true.) call var_list%set_int (var_str ("openmp_num_threads"), & 1, is_known = .true., force=.true.) call var_list%set_int (var_str ("real_range"), & 307, is_known = .true., force=.true.) call var_list%set_int (var_str ("real_precision"), & 15, is_known = .true., force=.true.) call var_list%set_real (var_str ("real_epsilon"), & 1.e-16_default, is_known = .true., force=.true.) call var_list%set_real (var_str ("real_tiny"), & 1.e-300_default, is_known = .true., force=.true.) global%os_data%fc = "Fortran-compiler" global%os_data%fcflags = "Fortran-flags" end subroutine fix_system_dependencies @ %def fix_system_dependencies @ <>= public :: show_description_of_string <>= subroutine show_description_of_string (string) type(string_t), intent(in) :: string type(rt_data_t), target :: global call global%global_init () call global%show_description_of_string (string, ascii_output=.true.) end subroutine show_description_of_string @ %def show_description_of_string @ <>= public :: show_tex_descriptions <>= subroutine show_tex_descriptions () type(rt_data_t), target :: global call global%global_init () call fix_system_dependencies (global) call global%set_int (var_str ("seed"), 0, is_known=.true.) call global%var_list%sort () call global%write_var_descriptions () end subroutine show_tex_descriptions @ %def show_tex_descriptions @ \subsection{Unit Tests} Test module, followed by the corresponding implementation module. <<[[rt_data_ut.f90]]>>= <> module rt_data_ut use unit_tests use rt_data_uti <> <> contains <> end module rt_data_ut @ %def rt_data_ut @ <<[[rt_data_uti.f90]]>>= <> module rt_data_uti <> <> use format_defs, only: FMT_19 use ifiles use lexers use parser use flavors use variables, only: var_list_t, var_entry_t, var_entry_init_int use eval_trees use models use prclib_stacks use rt_data <> <> contains <> <> end module rt_data_uti @ %def rt_data_ut @ API: driver for the unit tests below. <>= public :: rt_data_test <>= subroutine rt_data_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine rt_data_test @ %def rt_data_test @ \subsubsection{Initial content} @ Display the RT data in the state just after (global) initialization. <>= call test (rt_data_1, "rt_data_1", & "initialize", & u, results) <>= public :: rt_data_1 <>= subroutine rt_data_1 (u) integer, intent(in) :: u type(rt_data_t), target :: global write (u, "(A)") "* Test output: rt_data_1" write (u, "(A)") "* Purpose: initialize global runtime data" write (u, "(A)") call global%global_init (logfile = var_str ("rt_data.log")) call fix_system_dependencies (global) call global%set_int (var_str ("seed"), 0, is_known=.true.) call global%it_list%init ([2, 3], [5000, 20000]) call global%write (u) call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_1" end subroutine rt_data_1 @ %def rt_data_1 @ \subsubsection{Fill values} Fill in empty slots in the runtime data block. <>= call test (rt_data_2, "rt_data_2", & "fill", & u, results) <>= public :: rt_data_2 <>= subroutine rt_data_2 (u) integer, intent(in) :: u type(rt_data_t), target :: global type(flavor_t), dimension(2) :: flv type(string_t) :: cut_expr_text type(ifile_t) :: ifile type(stream_t) :: stream type(parse_tree_t) :: parse_tree write (u, "(A)") "* Test output: rt_data_2" write (u, "(A)") "* Purpose: initialize global runtime data & &and fill contents" write (u, "(A)") call syntax_model_file_init () call global%global_init () call fix_system_dependencies (global) call global%select_model (var_str ("Test")) call global%set_real (var_str ("sqrts"), & 1000._default, is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call flv%init ([25,25], global%model) call global%set_string (var_str ("$run_id"), & var_str ("run1"), is_known = .true.) call global%set_real (var_str ("luminosity"), & 33._default, is_known = .true.) call syntax_pexpr_init () cut_expr_text = "all Pt > 100 [s]" call ifile_append (ifile, cut_expr_text) call stream_init (stream, ifile) call parse_tree_init_lexpr (parse_tree, stream, .true.) global%pn%cuts_lexpr => parse_tree%get_root_ptr () allocate (global%sample_fmt (2)) global%sample_fmt(1) = "foo_fmt" global%sample_fmt(2) = "bar_fmt" call global%write (u) call parse_tree_final (parse_tree) call stream_final (stream) call ifile_final (ifile) call syntax_pexpr_final () call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_2" end subroutine rt_data_2 @ %def rt_data_2 @ \subsubsection{Save and restore} Set up a local runtime data block, change some contents, restore the global block. <>= call test (rt_data_3, "rt_data_3", & "save/restore", & u, results) <>= public :: rt_data_3 <>= subroutine rt_data_3 (u) use event_base, only: event_callback_nop_t integer, intent(in) :: u type(rt_data_t), target :: global, local type(flavor_t), dimension(2) :: flv type(string_t) :: cut_expr_text type(ifile_t) :: ifile type(stream_t) :: stream type(parse_tree_t) :: parse_tree type(prclib_entry_t), pointer :: lib type(event_callback_nop_t) :: event_callback_nop write (u, "(A)") "* Test output: rt_data_3" write (u, "(A)") "* Purpose: initialize global runtime data & &and fill contents;" write (u, "(A)") "* copy to local block and back" write (u, "(A)") write (u, "(A)") "* Init global data" write (u, "(A)") call syntax_model_file_init () call global%global_init () call fix_system_dependencies (global) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%select_model (var_str ("Test")) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call flv%init ([25,25], global%model) call global%beam_structure%init_sf (flv%get_name (), [1]) call global%beam_structure%set_sf (1, 1, var_str ("pdf_builtin")) call global%set_string (var_str ("$run_id"), & var_str ("run1"), is_known = .true.) call global%set_real (var_str ("luminosity"), & 33._default, is_known = .true.) call syntax_pexpr_init () cut_expr_text = "all Pt > 100 [s]" call ifile_append (ifile, cut_expr_text) call stream_init (stream, ifile) call parse_tree_init_lexpr (parse_tree, stream, .true.) global%pn%cuts_lexpr => parse_tree%get_root_ptr () allocate (global%sample_fmt (2)) global%sample_fmt(1) = "foo_fmt" global%sample_fmt(2) = "bar_fmt" allocate (lib) call lib%init (var_str ("library_1")) call global%add_prclib (lib) write (u, "(A)") "* Init and modify local data" write (u, "(A)") call local%local_init (global) call local%append_string (var_str ("$integration_method"), intrinsic=.true.) call local%append_string (var_str ("$phs_method"), intrinsic=.true.) call local%activate () write (u, "(1x,A,L1)") "model associated = ", associated (local%model) write (u, "(1x,A,L1)") "library associated = ", associated (local%prclib) write (u, *) call local%model_set_real (var_str ("ms"), 150._default) call local%set_string (var_str ("$integration_method"), & var_str ("midpoint"), is_known = .true.) call local%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) local%os_data%fc = "Local compiler" allocate (lib) call lib%init (var_str ("library_2")) call local%add_prclib (lib) call local%set_event_callback (event_callback_nop) call local%write (u) write (u, "(A)") write (u, "(A)") "* Restore global data" write (u, "(A)") call local%deactivate (global) write (u, "(1x,A,L1)") "model associated = ", associated (global%model) write (u, "(1x,A,L1)") "library associated = ", associated (global%prclib) write (u, *) call global%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call parse_tree_final (parse_tree) call stream_final (stream) call ifile_final (ifile) call syntax_pexpr_final () call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_3" end subroutine rt_data_3 @ %def rt_data_3 @ \subsubsection{Show variables} Display selected variables in the global record. <>= call test (rt_data_4, "rt_data_4", & "show variables", & u, results) <>= public :: rt_data_4 <>= subroutine rt_data_4 (u) integer, intent(in) :: u type(rt_data_t), target :: global type(string_t), dimension(0) :: empty_string_array write (u, "(A)") "* Test output: rt_data_4" write (u, "(A)") "* Purpose: display selected variables" write (u, "(A)") call global%global_init () write (u, "(A)") "* No variables:" write (u, "(A)") call global%write_vars (u, empty_string_array) write (u, "(A)") "* Two variables:" write (u, "(A)") call global%write_vars (u, & [var_str ("?unweighted"), var_str ("$phs_method")]) write (u, "(A)") write (u, "(A)") "* Display whole record with selected variables" write (u, "(A)") call global%write (u, & vars = [var_str ("?unweighted"), var_str ("$phs_method")]) call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_4" end subroutine rt_data_4 @ %def rt_data_4 @ \subsubsection{Show parts} Display only selected parts in the state just after (global) initialization. <>= call test (rt_data_5, "rt_data_5", & "show parts", & u, results) <>= public :: rt_data_5 <>= subroutine rt_data_5 (u) integer, intent(in) :: u type(rt_data_t), target :: global write (u, "(A)") "* Test output: rt_data_5" write (u, "(A)") "* Purpose: display parts of rt data" write (u, "(A)") call global%global_init () call global%write_libraries (u) write (u, "(A)") call global%write_beams (u) write (u, "(A)") call global%write_process_stack (u) call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_5" end subroutine rt_data_5 @ %def rt_data_5 @ \subsubsection{Local Model} Locally modify a model and restore the global one. We need an auxiliary function to determine the status of a model particle: <>= function is_stable (pdg, global) result (flag) integer, intent(in) :: pdg type(rt_data_t), intent(in) :: global logical :: flag type(flavor_t) :: flv call flv%init (pdg, global%model) flag = flv%is_stable () end function is_stable function is_polarized (pdg, global) result (flag) integer, intent(in) :: pdg type(rt_data_t), intent(in) :: global logical :: flag type(flavor_t) :: flv call flv%init (pdg, global%model) flag = flv%is_polarized () end function is_polarized @ %def is_stable is_polarized <>= call test (rt_data_6, "rt_data_6", & "local model", & u, results) <>= public :: rt_data_6 <>= subroutine rt_data_6 (u) integer, intent(in) :: u type(rt_data_t), target :: global, local type(var_list_t), pointer :: model_vars type(string_t) :: var_name write (u, "(A)") "* Test output: rt_data_6" write (u, "(A)") "* Purpose: apply and keep local modifications to model" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%select_model (var_str ("Test")) write (u, "(A)") "* Original model" write (u, "(A)") call global%write_model_list (u) write (u, *) write (u, "(A,L1)") "s is stable = ", is_stable (25, global) write (u, "(A,L1)") "f is polarized = ", is_polarized (6, global) write (u, *) var_name = "ff" write (u, "(A)", advance="no") "Global model variable: " model_vars => global%model%get_var_list_ptr () call model_vars%write_var (var_name, u) write (u, "(A)") write (u, "(A)") "* Apply local modifications: unstable" write (u, "(A)") call local%local_init (global) call local%activate () call local%model_set_real (var_name, 0.4_default) call local%modify_particle (25, stable = .false., decay = [var_str ("d1")]) call local%modify_particle (6, stable = .false., & decay = [var_str ("f1")], isotropic_decay = .true.) call local%modify_particle (-6, stable = .false., & decay = [var_str ("f2"), var_str ("f3")], diagonal_decay = .true.) call local%model%write (u) write (u, "(A)") write (u, "(A)") "* Further modifications" write (u, "(A)") call local%modify_particle (6, stable = .false., & decay = [var_str ("f1")], & diagonal_decay = .true., isotropic_decay = .false.) call local%modify_particle (-6, stable = .false., & decay = [var_str ("f2"), var_str ("f3")], & diagonal_decay = .false., isotropic_decay = .true.) call local%model%write (u) write (u, "(A)") write (u, "(A)") "* Further modifications: f stable but polarized" write (u, "(A)") call local%modify_particle (6, stable = .true., polarized = .true.) call local%modify_particle (-6, stable = .true.) call local%model%write (u) write (u, "(A)") write (u, "(A)") "* Global model" write (u, "(A)") call global%model%write (u) write (u, *) write (u, "(A,L1)") "s is stable = ", is_stable (25, global) write (u, "(A,L1)") "f is polarized = ", is_polarized (6, global) write (u, "(A)") write (u, "(A)") "* Local model" write (u, "(A)") call local%model%write (u) write (u, *) write (u, "(A,L1)") "s is stable = ", is_stable (25, local) write (u, "(A,L1)") "f is polarized = ", is_polarized (6, local) write (u, *) write (u, "(A)", advance="no") "Global model variable: " model_vars => global%model%get_var_list_ptr () call model_vars%write_var (var_name, u) write (u, "(A)", advance="no") "Local model variable: " associate (model_var_list_ptr => local%model%get_var_list_ptr()) call model_var_list_ptr%write_var (var_name, u) end associate write (u, "(A)") write (u, "(A)") "* Restore global" call local%deactivate (global, keep_local = .true.) write (u, "(A)") write (u, "(A)") "* Global model" write (u, "(A)") call global%model%write (u) write (u, *) write (u, "(A,L1)") "s is stable = ", is_stable (25, global) write (u, "(A,L1)") "f is polarized = ", is_polarized (6, global) write (u, "(A)") write (u, "(A)") "* Local model" write (u, "(A)") call local%model%write (u) write (u, *) write (u, "(A,L1)") "s is stable = ", is_stable (25, local) write (u, "(A,L1)") "f is polarized = ", is_polarized (6, local) write (u, *) write (u, "(A)", advance="no") "Global model variable: " model_vars => global%model%get_var_list_ptr () call model_vars%write_var (var_name, u) write (u, "(A)", advance="no") "Local model variable: " associate (model_var_list_ptr => local%model%get_var_list_ptr()) call model_var_list_ptr%write_var (var_name, u) end associate write (u, "(A)") write (u, "(A)") "* Cleanup" call local%model%final () deallocate (local%model) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_6" end subroutine rt_data_6 @ %def rt_data_6 @ \subsubsection{Result variables} Initialize result variables and check that they are accessible via the global variable list. <>= call test (rt_data_7, "rt_data_7", & "result variables", & u, results) <>= public :: rt_data_7 <>= subroutine rt_data_7 (u) integer, intent(in) :: u type(rt_data_t), target :: global write (u, "(A)") "* Test output: rt_data_7" write (u, "(A)") "* Purpose: set and access result variables" write (u, "(A)") write (u, "(A)") "* Initialize process variables" write (u, "(A)") call global%global_init () call global%process_stack%init_result_vars (var_str ("testproc")) call global%var_list%write_var (& var_str ("integral(testproc)"), u, defined=.true.) call global%var_list%write_var (& var_str ("error(testproc)"), u, defined=.true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_7" end subroutine rt_data_7 @ %def rt_data_7 @ \subsubsection{Beam energy} If beam parameters are set, the variable [[sqrts]] is not necessarily the collision energy. The method [[get_sqrts]] fetches the correct value. <>= call test (rt_data_8, "rt_data_8", & "beam energy", & u, results) <>= public :: rt_data_8 <>= subroutine rt_data_8 (u) integer, intent(in) :: u type(rt_data_t), target :: global write (u, "(A)") "* Test output: rt_data_8" write (u, "(A)") "* Purpose: get correct collision energy" write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") call global%global_init () write (u, "(A)") "* Set sqrts" write (u, "(A)") call global%set_real (var_str ("sqrts"), & 1000._default, is_known = .true.) write (u, "(1x,A," // FMT_19 // ")") "sqrts =", global%get_sqrts () write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_8" end subroutine rt_data_8 @ %def rt_data_8 @ \subsubsection{Local variable modifications} <>= call test (rt_data_9, "rt_data_9", & "local variables", & u, results) <>= public :: rt_data_9 <>= subroutine rt_data_9 (u) integer, intent(in) :: u type(rt_data_t), target :: global, local type(var_list_t), pointer :: var_list write (u, "(A)") "* Test output: rt_data_9" write (u, "(A)") "* Purpose: handle local variables" write (u, "(A)") call syntax_model_file_init () write (u, "(A)") "* Initialize global record and set some variables" write (u, "(A)") call global%global_init () call global%select_model (var_str ("Test")) call global%set_real (var_str ("sqrts"), 17._default, is_known = .true.) call global%set_real (var_str ("luminosity"), 2._default, is_known = .true.) call global%model_set_real (var_str ("ff"), 0.5_default) call global%model_set_real (var_str ("gy"), 1.2_default) var_list => global%get_var_list_ptr () call var_list%write_var (var_str ("sqrts"), u, defined=.true.) call var_list%write_var (var_str ("luminosity"), u, defined=.true.) call var_list%write_var (var_str ("ff"), u, defined=.true.) call var_list%write_var (var_str ("gy"), u, defined=.true.) call var_list%write_var (var_str ("mf"), u, defined=.true.) call var_list%write_var (var_str ("x"), u, defined=.true.) write (u, "(A)") write (u, "(1x,A,1x,F5.2)") "sqrts = ", & global%get_rval (var_str ("sqrts")) write (u, "(1x,A,1x,F5.2)") "luminosity = ", & global%get_rval (var_str ("luminosity")) write (u, "(1x,A,1x,F5.2)") "ff = ", & global%get_rval (var_str ("ff")) write (u, "(1x,A,1x,F5.2)") "gy = ", & global%get_rval (var_str ("gy")) write (u, "(1x,A,1x,F5.2)") "mf = ", & global%get_rval (var_str ("mf")) write (u, "(1x,A,1x,F5.2)") "x = ", & global%get_rval (var_str ("x")) write (u, "(A)") write (u, "(A)") "* Create local record with local variables" write (u, "(A)") call local%local_init (global) call local%append_real (var_str ("luminosity"), intrinsic = .true.) call local%append_real (var_str ("x"), user = .true.) call local%activate () var_list => local%get_var_list_ptr () call var_list%write_var (var_str ("sqrts"), u) call var_list%write_var (var_str ("luminosity"), u) call var_list%write_var (var_str ("ff"), u) call var_list%write_var (var_str ("gy"), u) call var_list%write_var (var_str ("mf"), u) call var_list%write_var (var_str ("x"), u, defined=.true.) write (u, "(A)") write (u, "(1x,A,1x,F5.2)") "sqrts = ", & local%get_rval (var_str ("sqrts")) write (u, "(1x,A,1x,F5.2)") "luminosity = ", & local%get_rval (var_str ("luminosity")) write (u, "(1x,A,1x,F5.2)") "ff = ", & local%get_rval (var_str ("ff")) write (u, "(1x,A,1x,F5.2)") "gy = ", & local%get_rval (var_str ("gy")) write (u, "(1x,A,1x,F5.2)") "mf = ", & local%get_rval (var_str ("mf")) write (u, "(1x,A,1x,F5.2)") "x = ", & local%get_rval (var_str ("x")) write (u, "(A)") write (u, "(A)") "* Modify some local variables" write (u, "(A)") call local%set_real (var_str ("luminosity"), 42._default, is_known=.true.) call local%set_real (var_str ("x"), 6.66_default, is_known=.true.) call local%model_set_real (var_str ("ff"), 0.7_default) var_list => local%get_var_list_ptr () call var_list%write_var (var_str ("sqrts"), u) call var_list%write_var (var_str ("luminosity"), u) call var_list%write_var (var_str ("ff"), u) call var_list%write_var (var_str ("gy"), u) call var_list%write_var (var_str ("mf"), u) call var_list%write_var (var_str ("x"), u, defined=.true.) write (u, "(A)") write (u, "(1x,A,1x,F5.2)") "sqrts = ", & local%get_rval (var_str ("sqrts")) write (u, "(1x,A,1x,F5.2)") "luminosity = ", & local%get_rval (var_str ("luminosity")) write (u, "(1x,A,1x,F5.2)") "ff = ", & local%get_rval (var_str ("ff")) write (u, "(1x,A,1x,F5.2)") "gy = ", & local%get_rval (var_str ("gy")) write (u, "(1x,A,1x,F5.2)") "mf = ", & local%get_rval (var_str ("mf")) write (u, "(1x,A,1x,F5.2)") "x = ", & local%get_rval (var_str ("x")) write (u, "(A)") write (u, "(A)") "* Restore globals" write (u, "(A)") call local%deactivate (global) var_list => global%get_var_list_ptr () call var_list%write_var (var_str ("sqrts"), u) call var_list%write_var (var_str ("luminosity"), u) call var_list%write_var (var_str ("ff"), u) call var_list%write_var (var_str ("gy"), u) call var_list%write_var (var_str ("mf"), u) call var_list%write_var (var_str ("x"), u, defined=.true.) write (u, "(A)") write (u, "(1x,A,1x,F5.2)") "sqrts = ", & global%get_rval (var_str ("sqrts")) write (u, "(1x,A,1x,F5.2)") "luminosity = ", & global%get_rval (var_str ("luminosity")) write (u, "(1x,A,1x,F5.2)") "ff = ", & global%get_rval (var_str ("ff")) write (u, "(1x,A,1x,F5.2)") "gy = ", & global%get_rval (var_str ("gy")) write (u, "(1x,A,1x,F5.2)") "mf = ", & global%get_rval (var_str ("mf")) write (u, "(1x,A,1x,F5.2)") "x = ", & global%get_rval (var_str ("x")) write (u, "(A)") write (u, "(A)") "* Cleanup" call local%local_final () call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_9" end subroutine rt_data_9 @ %def rt_data_9 @ \subsubsection{Descriptions} <>= call test(rt_data_10, "rt_data_10", & "descriptions", u, results) <>= public :: rt_data_10 <>= subroutine rt_data_10 (u) integer, intent(in) :: u type(rt_data_t) :: global ! type(var_list_t) :: var_list write (u, "(A)") "* Test output: rt_data_10" write (u, "(A)") "* Purpose: display descriptions" write (u, "(A)") call global%var_list%append_real (var_str ("sqrts"), & intrinsic=.true., & description=var_str ('Real variable in order to set the center-of-mass ' // & 'energy for the collisions.')) call global%var_list%append_real (var_str ("luminosity"), 0._default, & intrinsic=.true., & description=var_str ('This specifier \ttt{luminosity = {\em ' // & '}} sets the integrated luminosity (in inverse femtobarns, ' // & 'fb${}^{-1}$) for the event generation of the processes in the ' // & '\sindarin\ input files.')) call global%var_list%append_int (var_str ("seed"), 1234, & intrinsic=.true., & description=var_str ('Integer variable \ttt{seed = {\em }} ' // & 'that allows to set a specific random seed \ttt{num}.')) call global%var_list%append_string (var_str ("$method"), var_str ("omega"), & intrinsic=.true., & description=var_str ('This string variable specifies the method ' // & 'for the matrix elements to be used in the evaluation.')) call global%var_list%append_log (var_str ("?read_color_factors"), .true., & intrinsic=.true., & description=var_str ('This flag decides whether to read QCD ' // & 'color factors from the matrix element provided by each method, ' // & 'or to try and calculate the color factors in \whizard\ internally.')) call global%var_list%sort () call global%write_var_descriptions (u) call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_10" end subroutine rt_data_10 @ %def rt_data_10 @ \subsubsection{Export objects} Export objects are variables or other data that should be copied or otherwise applied to corresponding objects in the outer scope. We test appending and retrieval for the export list. <>= call test(rt_data_11, "rt_data_11", & "export objects", u, results) <>= public :: rt_data_11 <>= subroutine rt_data_11 (u) integer, intent(in) :: u type(rt_data_t) :: global type(string_t), dimension(:), allocatable :: exports integer :: i write (u, "(A)") "* Test output: rt_data_11" write (u, "(A)") "* Purpose: handle export object list" write (u, "(A)") write (u, "(A)") "* Empty export list" write (u, "(A)") call global%write_exports (u) write (u, "(A)") "* Add an entry" write (u, "(A)") allocate (exports (1)) exports(1) = var_str ("results") do i = 1, size (exports) write (u, "('+ ',A)") char (exports(i)) end do write (u, *) call global%append_exports (exports) call global%write_exports (u) write (u, "(A)") write (u, "(A)") "* Add more entries, including doubler" write (u, "(A)") deallocate (exports) allocate (exports (3)) exports(1) = var_str ("foo") exports(2) = var_str ("results") exports(3) = var_str ("bar") do i = 1, size (exports) write (u, "('+ ',A)") char (exports(i)) end do write (u, *) call global%append_exports (exports) call global%write_exports (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: rt_data_11" end subroutine rt_data_11 @ %def rt_data_11 @ @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Select implementations} For abstract types (process core, integrator, phase space, etc.), we need a way to dynamically select a concrete type, using either data given by the user or a previous selection of a concrete type. This is done by subroutines in the current module. We would like to put this in the [[me_methods]] folder but it also depends on [[gosam]] and [[openloops]], so it is unclear where to put it. <<[[dispatch_me_methods.f90]]>>= <> module dispatch_me_methods <> use physics_defs, only: BORN use diagnostics use sm_qcd use variables, only: var_list_t use models use model_data use prc_core_def use prc_core use prc_test_core use prc_template_me use prc_test use prc_omega use prc_external use prc_gosam use prc_openloops use prc_recola use prc_threshold <> <> contains <> end module dispatch_me_methods @ %def dispatch_me_methods @ \subsection{Process Core Definition} The [[prc_core_def_t]] abstract type can be instantiated by providing a [[$method]] string variable. Note: [[core_def]] has intent(inout) because gfortran 4.7.1 crashes for intent(out). <>= public :: dispatch_core_def <>= subroutine dispatch_core_def (core_def, prt_in, prt_out, & model, var_list, id, nlo_type, method) class(prc_core_def_t), allocatable, intent(inout) :: core_def type(string_t), dimension(:), intent(in) :: prt_in type(string_t), dimension(:), intent(in) :: prt_out type(model_t), pointer, intent(in) :: model type(var_list_t), intent(in) :: var_list type(string_t), intent(in), optional :: id integer, intent(in), optional :: nlo_type type(string_t), intent(in), optional :: method type(string_t) :: model_name, meth type(string_t) :: ufo_path type(string_t) :: restrictions logical :: ufo logical :: cms_scheme logical :: openmp_support logical :: report_progress logical :: diags, diags_color logical :: write_phs_output type(string_t) :: extra_options integer :: nlo integer :: alpha_power integer :: alphas_power if (present (method)) then meth = method else meth = var_list%get_sval (var_str ("$method")) end if call msg_debug2 (D_CORE, "dispatch_core_def") if (associated (model)) then model_name = model%get_name () cms_scheme = model%get_scheme () == "Complex_Mass_Scheme" ufo = model%is_ufo_model () ufo_path = model%get_ufo_path () else model_name = "" cms_scheme = .false. ufo = .false. end if restrictions = var_list%get_sval (& var_str ("$restrictions")) diags = var_list%get_lval (& var_str ("?vis_diags")) diags_color = var_list%get_lval (& var_str ("?vis_diags_color")) openmp_support = var_list%get_lval (& var_str ("?omega_openmp")) report_progress = var_list%get_lval (& var_str ("?report_progress")) write_phs_output = var_list%get_lval (& var_str ("?omega_write_phs_output")) extra_options = var_list%get_sval (& var_str ("$omega_flags")) nlo = BORN; if (present (nlo_type)) nlo = nlo_type alpha_power = var_list%get_ival (var_str ("alpha_power")) alphas_power = var_list%get_ival (var_str ("alphas_power")) call msg_debug2 (D_CORE, "dispatching core method: ", meth) select case (char (meth)) case ("unit_test") allocate (prc_test_def_t :: core_def) select type (core_def) type is (prc_test_def_t) call core_def%init (model_name, prt_in, prt_out) end select case ("template") allocate (template_me_def_t :: core_def) select type (core_def) type is (template_me_def_t) call core_def%init (model, prt_in, prt_out, unity = .false.) end select case ("template_unity") allocate (template_me_def_t :: core_def) select type (core_def) type is (template_me_def_t) call core_def%init (model, prt_in, prt_out, unity = .true.) end select case ("omega") allocate (omega_def_t :: core_def) select type (core_def) type is (omega_def_t) call core_def%init (model_name, prt_in, prt_out, & .false., ufo, ufo_path, & restrictions, cms_scheme, & openmp_support, report_progress, write_phs_output, & extra_options, diags, diags_color) end select case ("ovm") allocate (omega_def_t :: core_def) select type (core_def) type is (omega_def_t) call core_def%init (model_name, prt_in, prt_out, & .true., .false., var_str (""), & restrictions, cms_scheme, & openmp_support, report_progress, write_phs_output, & extra_options, diags, diags_color) end select case ("gosam") allocate (gosam_def_t :: core_def) select type (core_def) type is (gosam_def_t) if (present (id)) then call core_def%init (id, model_name, prt_in, & prt_out, nlo, var_list) else call msg_fatal ("Dispatch GoSam def: No id!") end if end select case ("openloops") allocate (openloops_def_t :: core_def) select type (core_def) type is (openloops_def_t) if (present (id)) then call core_def%init (id, model_name, prt_in, & prt_out, nlo, var_list) else call msg_fatal ("Dispatch OpenLoops def: No id!") end if end select case ("recola") call abort_if_recola_not_active () allocate (recola_def_t :: core_def) select type (core_def) type is (recola_def_t) if (present (id)) then call core_def%init (id, model_name, prt_in, & prt_out, nlo, alpha_power, alphas_power) else call msg_fatal ("Dispatch RECOLA def: No id!") end if end select case ("dummy") allocate (prc_external_test_def_t :: core_def) select type (core_def) type is (prc_external_test_def_t) if (present (id)) then call core_def%init (id, model_name, prt_in, prt_out) else call msg_fatal ("Dispatch User-Defined Test def: No id!") end if end select case ("threshold") allocate (threshold_def_t :: core_def) select type (core_def) type is (threshold_def_t) if (present (id)) then call core_def%init (id, model_name, prt_in, prt_out, & nlo, restrictions) else call msg_fatal ("Dispatch Threshold def: No id!") end if end select case default call msg_fatal ("Process configuration: method '" & // char (meth) // "' not implemented") end select end subroutine dispatch_core_def @ %def dispatch_core_def @ \subsection{Process core allocation} Here we allocate an object of abstract type [[prc_core_t]] with a concrete type that matches a process definition. The [[prc_omega_t]] extension will require the current parameter set, so we take the opportunity to grab it from the model. <>= public :: dispatch_core <>= subroutine dispatch_core (core, core_def, model, & helicity_selection, qcd, use_color_factors, has_beam_pol) class(prc_core_t), allocatable, intent(inout) :: core class(prc_core_def_t), intent(in) :: core_def class(model_data_t), intent(in), target, optional :: model type(helicity_selection_t), intent(in), optional :: helicity_selection type(qcd_t), intent(in), optional :: qcd logical, intent(in), optional :: use_color_factors logical, intent(in), optional :: has_beam_pol select type (core_def) type is (prc_test_def_t) allocate (test_t :: core) type is (template_me_def_t) allocate (prc_template_me_t :: core) select type (core) type is (prc_template_me_t) call core%set_parameters (model) end select class is (omega_def_t) if (.not. allocated (core)) allocate (prc_omega_t :: core) select type (core) type is (prc_omega_t) call core%set_parameters (model, & helicity_selection, qcd, use_color_factors) end select type is (gosam_def_t) if (.not. allocated (core)) allocate (prc_gosam_t :: core) select type (core) type is (prc_gosam_t) call core%set_parameters (qcd) end select type is (openloops_def_t) if (.not. allocated (core)) allocate (prc_openloops_t :: core) select type (core) type is (prc_openloops_t) call core%set_parameters (qcd) end select type is (recola_def_t) if (.not. allocated (core)) allocate (prc_recola_t :: core) select type (core) type is (prc_recola_t) call core%set_parameters (qcd, model) end select type is (prc_external_test_def_t) if (.not. allocated (core)) allocate (prc_external_test_t :: core) select type (core) type is (prc_external_test_t) call core%set_parameters (qcd, model) end select type is (threshold_def_t) if (.not. allocated (core)) allocate (prc_threshold_t :: core) select type (core) type is (prc_threshold_t) call core%set_parameters (qcd, model) call core%set_beam_pol (has_beam_pol) end select class default call msg_bug ("Process core: unexpected process definition type") end select end subroutine dispatch_core @ %def dispatch_core @ \subsection{Process core update and restoration} Here we take an existing object of abstract type [[prc_core_t]] and update the parameters as given by the current state of [[model]]. Optionally, we can save the previous state as [[saved_core]]. The second routine restores the original from the save. (In the test case, there is no possible update.) <>= public :: dispatch_core_update public :: dispatch_core_restore <>= subroutine dispatch_core_update & (core, model, helicity_selection, qcd, saved_core) class(prc_core_t), allocatable, intent(inout) :: core class(model_data_t), intent(in), optional, target :: model type(helicity_selection_t), intent(in), optional :: helicity_selection type(qcd_t), intent(in), optional :: qcd class(prc_core_t), allocatable, intent(inout), optional :: saved_core if (present (saved_core)) then allocate (saved_core, source = core) end if select type (core) type is (test_t) type is (prc_omega_t) call core%set_parameters (model, helicity_selection, qcd) call core%activate_parameters () class is (prc_external_t) call msg_message ("Updating user defined cores is not implemented yet.") class default call msg_bug ("Process core update: unexpected process definition type") end select end subroutine dispatch_core_update subroutine dispatch_core_restore (core, saved_core) class(prc_core_t), allocatable, intent(inout) :: core class(prc_core_t), allocatable, intent(inout) :: saved_core call move_alloc (from = saved_core, to = core) select type (core) type is (test_t) type is (prc_omega_t) call core%activate_parameters () class default call msg_bug ("Process core restore: unexpected process definition type") end select end subroutine dispatch_core_restore @ %def dispatch_core_update dispatch_core_restore @ \subsection{Unit Tests} Test module, followed by the corresponding implementation module. <<[[dispatch_ut.f90]]>>= <> module dispatch_ut use unit_tests use dispatch_uti <> <> <> contains <> end module dispatch_ut @ %def dispatch_ut @ <<[[dispatch_uti.f90]]>>= <> module dispatch_uti <> <> use os_interface, only: os_data_t use physics_defs, only: ELECTRON, PROTON use sm_qcd, only: qcd_t use flavors, only: flavor_t use interactions, only: reset_interaction_counter use pdg_arrays, only: pdg_array_t, assignment(=) use prc_core_def, only: prc_core_def_t use prc_test_core, only: test_t use prc_core, only: prc_core_t use prc_test, only: prc_test_def_t use prc_omega, only: omega_def_t, prc_omega_t use sf_mappings, only: sf_channel_t use sf_base, only: sf_data_t, sf_config_t use phs_base, only: phs_channel_collection_t use variables, only: var_list_t use model_data, only: model_data_t use models, only: syntax_model_file_init, syntax_model_file_final use rt_data, only: rt_data_t use dispatch_phase_space, only: dispatch_sf_channels use dispatch_beams, only: sf_prop_t, dispatch_qcd use dispatch_beams, only: dispatch_sf_config, dispatch_sf_data use dispatch_me_methods, only: dispatch_core_def, dispatch_core use dispatch_me_methods, only: dispatch_core_update, dispatch_core_restore use sf_base_ut, only: sf_test_data_t <> <> <> contains <> <> end module dispatch_uti @ %def dispatch_uti @ API: driver for the unit tests below. <>= public :: dispatch_test <>= subroutine dispatch_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine dispatch_test @ %def dispatch_test @ \subsubsection{Select type: process definition} <>= call test (dispatch_1, "dispatch_1", & "process configuration method", & u, results) <>= public :: dispatch_1 <>= subroutine dispatch_1 (u) integer, intent(in) :: u type(string_t), dimension(2) :: prt_in, prt_out type(rt_data_t), target :: global class(prc_core_def_t), allocatable :: core_def write (u, "(A)") "* Test output: dispatch_1" write (u, "(A)") "* Purpose: select process configuration method" write (u, "(A)") call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) prt_in = [var_str ("a"), var_str ("b")] prt_out = [var_str ("c"), var_str ("d")] write (u, "(A)") "* Allocate core_def as prc_test_def" call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list) select type (core_def) type is (prc_test_def_t) call core_def%write (u) end select deallocate (core_def) write (u, "(A)") write (u, "(A)") "* Allocate core_def as omega_def" write (u, "(A)") call global%set_string (var_str ("$method"), & var_str ("omega"), is_known = .true.) call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list) select type (core_def) type is (omega_def_t) call core_def%write (u) end select call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_1" end subroutine dispatch_1 @ %def dispatch_1 @ \subsubsection{Select type: process core} <>= call test (dispatch_2, "dispatch_2", & "process core", & u, results) <>= public :: dispatch_2 <>= subroutine dispatch_2 (u) integer, intent(in) :: u type(string_t), dimension(2) :: prt_in, prt_out type(rt_data_t), target :: global class(prc_core_def_t), allocatable :: core_def class(prc_core_t), allocatable :: core write (u, "(A)") "* Test output: dispatch_2" write (u, "(A)") "* Purpose: select process configuration method" write (u, "(A)") " and allocate process core" write (u, "(A)") call syntax_model_file_init () call global%global_init () prt_in = [var_str ("a"), var_str ("b")] prt_out = [var_str ("c"), var_str ("d")] write (u, "(A)") "* Allocate core as test_t" write (u, "(A)") call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list) call dispatch_core (core, core_def) select type (core) type is (test_t) call core%write (u) end select deallocate (core) deallocate (core_def) write (u, "(A)") write (u, "(A)") "* Allocate core as prc_omega_t" write (u, "(A)") call global%set_string (var_str ("$method"), & var_str ("omega"), is_known = .true.) call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list) call global%select_model (var_str ("Test")) call global%set_log (& var_str ("?helicity_selection_active"), & .true., is_known = .true.) call global%set_real (& var_str ("helicity_selection_threshold"), & 1e9_default, is_known = .true.) call global%set_int (& var_str ("helicity_selection_cutoff"), & 10, is_known = .true.) call dispatch_core (core, core_def, & global%model, & global%get_helicity_selection ()) call core_def%allocate_driver (core%driver, var_str ("")) select type (core) type is (prc_omega_t) call core%write (u) end select call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_2" end subroutine dispatch_2 @ %def dispatch_2 @ \subsubsection{Select type: structure-function data} This is an extra dispatcher that enables the test structure functions. This procedure should be assigned to the [[dispatch_sf_data_extra]] hook before any tests are executed. <>= public :: dispatch_sf_data_test <>= subroutine dispatch_sf_data_test (data, sf_method, i_beam, sf_prop, & var_list, var_list_global, model, os_data, sqrts, pdg_in, pdg_prc, polarized) class(sf_data_t), allocatable, intent(inout) :: data type(string_t), intent(in) :: sf_method integer, dimension(:), intent(in) :: i_beam type(var_list_t), intent(in) :: var_list type(var_list_t), intent(inout) :: var_list_global class(model_data_t), target, intent(in) :: model type(os_data_t), intent(in) :: os_data real(default), intent(in) :: sqrts type(pdg_array_t), dimension(:), intent(inout) :: pdg_in type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc type(sf_prop_t), intent(inout) :: sf_prop logical, intent(in) :: polarized select case (char (sf_method)) case ("sf_test_0", "sf_test_1") allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) select case (char (sf_method)) case ("sf_test_0"); call data%init (model, pdg_in(i_beam(1))) case ("sf_test_1"); call data%init (model, pdg_in(i_beam(1)),& mode = 1) end select end select end select end subroutine dispatch_sf_data_test @ %def dispatch_sf_data_test @ The actual test. We can't move this to [[beams]] as it depends on [[model_features]] for the [[model_list_t]]. <>= call test (dispatch_7, "dispatch_7", & "structure-function data", & u, results) <>= public :: dispatch_7 <>= subroutine dispatch_7 (u) integer, intent(in) :: u type(rt_data_t), target :: global type(os_data_t) :: os_data type(string_t) :: prt, sf_method type(sf_prop_t) :: sf_prop class(sf_data_t), allocatable :: data type(pdg_array_t), dimension(1) :: pdg_in type(pdg_array_t), dimension(1,1) :: pdg_prc type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 write (u, "(A)") "* Test output: dispatch_7" write (u, "(A)") "* Purpose: select and configure & &structure function data" write (u, "(A)") call global%global_init () call os_data%init () call syntax_model_file_init () call global%select_model (var_str ("QCD")) call reset_interaction_counter () call global%set_real (var_str ("sqrts"), & 14000._default, is_known = .true.) prt = "p" call global%beam_structure%init_sf ([prt, prt], [1]) pdg_in = 2212 write (u, "(A)") "* Allocate data as sf_pdf_builtin_t" write (u, "(A)") sf_method = "pdf_builtin" call dispatch_sf_data (data, sf_method, [1], sf_prop, & global%get_var_list_ptr (), global%var_list, & global%model, global%os_data, global%get_sqrts (), & pdg_in, pdg_prc, .false.) call data%write (u) call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(A)") write (u, "(1x,A,99(1x,I0))") "PDG(out) = ", pdg1 deallocate (data) write (u, "(A)") write (u, "(A)") "* Allocate data for different PDF set" write (u, "(A)") pdg_in = 2212 call global%set_string (var_str ("$pdf_builtin_set"), & var_str ("CTEQ6M"), is_known = .true.) sf_method = "pdf_builtin" call dispatch_sf_data (data, sf_method, [1], sf_prop, & global%get_var_list_ptr (), global%var_list, & global%model, global%os_data, global%get_sqrts (), & pdg_in, pdg_prc, .false.) call data%write (u) call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(A)") write (u, "(1x,A,99(1x,I0))") "PDG(out) = ", pdg1 deallocate (data) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_7" end subroutine dispatch_7 @ %def dispatch_7 @ \subsubsection{Beam structure} The actual test. We can't move this to [[beams]] as it depends on [[model_features]] for the [[model_list_t]]. <>= call test (dispatch_8, "dispatch_8", & "beam structure", & u, results) <>= public :: dispatch_8 <>= subroutine dispatch_8 (u) integer, intent(in) :: u type(rt_data_t), target :: global type(os_data_t) :: os_data type(flavor_t), dimension(2) :: flv type(sf_config_t), dimension(:), allocatable :: sf_config type(sf_prop_t) :: sf_prop type(sf_channel_t), dimension(:), allocatable :: sf_channel type(phs_channel_collection_t) :: coll type(string_t) :: sf_string integer :: i type(pdg_array_t), dimension (2,1) :: pdg_prc write (u, "(A)") "* Test output: dispatch_8" write (u, "(A)") "* Purpose: configure a structure-function chain" write (u, "(A)") call global%global_init () call os_data%init () call syntax_model_file_init () call global%select_model (var_str ("QCD")) write (u, "(A)") "* Allocate LHC beams with PDF builtin" write (u, "(A)") call flv(1)%init (PROTON, global%model) call flv(2)%init (PROTON, global%model) call reset_interaction_counter () call global%set_real (var_str ("sqrts"), & 14000._default, is_known = .true.) call global%beam_structure%init_sf (flv%get_name (), [1]) call global%beam_structure%set_sf (1, 1, var_str ("pdf_builtin")) call dispatch_sf_config (sf_config, sf_prop, global%beam_structure, & global%get_var_list_ptr (), global%var_list, & global%model, global%os_data, global%get_sqrts (), pdg_prc) do i = 1, size (sf_config) call sf_config(i)%write (u) end do call dispatch_sf_channels (sf_channel, sf_string, sf_prop, coll, & global%var_list, global%get_sqrts(), global%beam_structure) write (u, "(1x,A)") "Mapping configuration:" do i = 1, size (sf_channel) write (u, "(2x)", advance = "no") call sf_channel(i)%write (u) end do write (u, "(A)") write (u, "(A)") "* Allocate ILC beams with CIRCE1" write (u, "(A)") call global%select_model (var_str ("QED")) call flv(1)%init ( ELECTRON, global%model) call flv(2)%init (-ELECTRON, global%model) call reset_interaction_counter () call global%set_real (var_str ("sqrts"), & 500._default, is_known = .true.) call global%set_log (var_str ("?circe1_generate"), & .false., is_known = .true.) call global%beam_structure%init_sf (flv%get_name (), [1]) call global%beam_structure%set_sf (1, 1, var_str ("circe1")) call dispatch_sf_config (sf_config, sf_prop, global%beam_structure, & global%get_var_list_ptr (), global%var_list, & global%model, global%os_data, global%get_sqrts (), pdg_prc) do i = 1, size (sf_config) call sf_config(i)%write (u) end do call dispatch_sf_channels (sf_channel, sf_string, sf_prop, coll, & global%var_list, global%get_sqrts(), global%beam_structure) write (u, "(1x,A)") "Mapping configuration:" do i = 1, size (sf_channel) write (u, "(2x)", advance = "no") call sf_channel(i)%write (u) end do write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_8" end subroutine dispatch_8 @ %def dispatch_8 @ \subsubsection{Update process core parameters} This test dispatches a process core, temporarily modifies parameters, then restores the original. <>= call test (dispatch_10, "dispatch_10", & "process core update", & u, results) <>= public :: dispatch_10 <>= subroutine dispatch_10 (u) integer, intent(in) :: u type(string_t), dimension(2) :: prt_in, prt_out type(rt_data_t), target :: global class(prc_core_def_t), allocatable :: core_def class(prc_core_t), allocatable :: core, saved_core type(var_list_t), pointer :: model_vars write (u, "(A)") "* Test output: dispatch_10" write (u, "(A)") "* Purpose: select process configuration method," write (u, "(A)") " allocate process core," write (u, "(A)") " temporarily reset parameters" write (u, "(A)") call syntax_model_file_init () call global%global_init () prt_in = [var_str ("a"), var_str ("b")] prt_out = [var_str ("c"), var_str ("d")] write (u, "(A)") "* Allocate core as prc_omega_t" write (u, "(A)") call global%set_string (var_str ("$method"), & var_str ("omega"), is_known = .true.) call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list) call global%select_model (var_str ("Test")) call dispatch_core (core, core_def, global%model) call core_def%allocate_driver (core%driver, var_str ("")) select type (core) type is (prc_omega_t) call core%write (u) end select write (u, "(A)") write (u, "(A)") "* Update core with modified model and helicity selection" write (u, "(A)") model_vars => global%model%get_var_list_ptr () call model_vars%set_real (var_str ("gy"), 2._default, & is_known = .true.) call global%model%update_parameters () call global%set_log (& var_str ("?helicity_selection_active"), & .true., is_known = .true.) call global%set_real (& var_str ("helicity_selection_threshold"), & 2e10_default, is_known = .true.) call global%set_int (& var_str ("helicity_selection_cutoff"), & 5, is_known = .true.) call dispatch_core_update (core, & global%model, & global%get_helicity_selection (), & saved_core = saved_core) select type (core) type is (prc_omega_t) call core%write (u) end select write (u, "(A)") write (u, "(A)") "* Restore core from save" write (u, "(A)") call dispatch_core_restore (core, saved_core) select type (core) type is (prc_omega_t) call core%write (u) end select call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_10" end subroutine dispatch_10 @ %def dispatch_10 @ \subsubsection{QCD Coupling} This test dispatches an [[qcd]] object, which is used to compute the (running) coupling by one of several possible methods. We can't move this to [[beams]] as it depends on [[model_features]] for the [[model_list_t]]. <>= call test (dispatch_11, "dispatch_11", & "QCD coupling", & u, results) <>= public :: dispatch_11 <>= subroutine dispatch_11 (u) integer, intent(in) :: u type(rt_data_t), target :: global type(var_list_t), pointer :: model_vars type(qcd_t) :: qcd write (u, "(A)") "* Test output: dispatch_11" write (u, "(A)") "* Purpose: select QCD coupling formula" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%select_model (var_str ("SM")) model_vars => global%get_var_list_ptr () write (u, "(A)") "* Allocate alpha_s as fixed" write (u, "(A)") call global%set_log (var_str ("?alphas_is_fixed"), & .true., is_known = .true.) call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data) call qcd%write (u) write (u, "(A)") write (u, "(A)") "* Allocate alpha_s as running (built-in)" write (u, "(A)") call global%set_log (var_str ("?alphas_is_fixed"), & .false., is_known = .true.) call global%set_log (var_str ("?alphas_from_mz"), & .true., is_known = .true.) call global%set_int & (var_str ("alphas_order"), 1, is_known = .true.) call model_vars%set_real (var_str ("alphas"), 0.1234_default, & is_known=.true.) call model_vars%set_real (var_str ("mZ"), 91.234_default, & is_known=.true.) call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data) call qcd%write (u) write (u, "(A)") write (u, "(A)") "* Allocate alpha_s as running (built-in, Lambda defined)" write (u, "(A)") call global%set_log (var_str ("?alphas_from_mz"), & .false., is_known = .true.) call global%set_log (& var_str ("?alphas_from_lambda_qcd"), & .true., is_known = .true.) call global%set_real & (var_str ("lambda_qcd"), 250.e-3_default, & is_known=.true.) call global%set_int & (var_str ("alphas_order"), 2, is_known = .true.) call global%set_int & (var_str ("alphas_nf"), 4, is_known = .true.) call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data) call qcd%write (u) write (u, "(A)") write (u, "(A)") "* Allocate alpha_s as running (using builtin PDF set)" write (u, "(A)") call global%set_log (& var_str ("?alphas_from_lambda_qcd"), & .false., is_known = .true.) call global%set_log & (var_str ("?alphas_from_pdf_builtin"), & .true., is_known = .true.) call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data) call qcd%write (u) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_11" end subroutine dispatch_11 @ %def dispatch_11 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process Configuration} This module communicates between the toplevel command structure with its runtime data set and the process-library handling modules which collect the definition of individual processes. Its primary purpose is to select from the available matrix-element generating methods and configure the entry in the process library accordingly. <<[[process_configurations.f90]]>>= <> module process_configurations <> use diagnostics use io_units use physics_defs, only: BORN, NLO_VIRTUAL, NLO_REAL, NLO_DGLAP, & NLO_SUBTRACTION, NLO_MISMATCH use models use prc_core_def use particle_specifiers use process_libraries use rt_data use variables, only: var_list_t use dispatch_me_methods, only: dispatch_core_def use prc_external, only: prc_external_def_t <> <> <> contains <> end module process_configurations @ %def process_configurations @ \subsection{Data Type} <>= public :: process_configuration_t <>= type :: process_configuration_t type(process_def_entry_t), pointer :: entry => null () type(string_t) :: id integer :: num_id = 0 contains <> end type process_configuration_t @ %def process_configuration_t @ Output (for unit tests). <>= procedure :: write => process_configuration_write <>= subroutine process_configuration_write (config, unit) class(process_configuration_t), intent(in) :: config integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(A)") "Process configuration:" if (associated (config%entry)) then call config%entry%write (u) else write (u, "(1x,3A)") "ID = '", char (config%id), "'" write (u, "(1x,A,1x,I0)") "num ID =", config%num_id write (u, "(2x,A)") "[no entry]" end if end subroutine process_configuration_write @ %def process_configuration_write @ Initialize a process. We only need the name, the number of incoming particles, and the number of components. <>= procedure :: init => process_configuration_init <>= subroutine process_configuration_init & (config, prc_name, n_in, n_components, model, var_list, nlo_process) class(process_configuration_t), intent(out) :: config type(string_t), intent(in) :: prc_name integer, intent(in) :: n_in integer, intent(in) :: n_components type(model_t), intent(in), pointer :: model type(var_list_t), intent(in) :: var_list logical, intent(in), optional :: nlo_process logical :: nlo_proc logical :: requires_resonances call msg_debug (D_CORE, "process_configuration_init") config%id = prc_name if (present (nlo_process)) then nlo_proc = nlo_process else nlo_proc = .false. end if requires_resonances = var_list%get_lval (var_str ("?resonance_history")) call msg_debug (D_CORE, "nlo_process", nlo_proc) allocate (config%entry) if (var_list%is_known (var_str ("process_num_id"))) then config%num_id = & var_list%get_ival (var_str ("process_num_id")) call config%entry%init (prc_name, & model = model, n_in = n_in, n_components = n_components, & num_id = config%num_id, & nlo_process = nlo_proc, & requires_resonances = requires_resonances) else call config%entry%init (prc_name, & model = model, n_in = n_in, n_components = n_components, & nlo_process = nlo_proc, & requires_resonances = requires_resonances) end if end subroutine process_configuration_init @ %def process_configuration_init @ Initialize a process component. The details depend on the process method, which determines the type of the process component core. We set the incoming and outgoing particles (as strings, to be interpreted by the process driver). All other information is taken from the variable list. The dispatcher gets only the names of the particles. The process component definition gets the complete specifiers which contains a polarization flag and names of decay processes, where applicable. <>= procedure :: setup_component => process_configuration_setup_component <>= subroutine process_configuration_setup_component & (config, i_component, prt_in, prt_out, model, var_list, & nlo_type, can_be_integrated) class(process_configuration_t), intent(inout) :: config integer, intent(in) :: i_component type(prt_spec_t), dimension(:), intent(in) :: prt_in type(prt_spec_t), dimension(:), intent(in) :: prt_out type(model_t), pointer, intent(in) :: model type(var_list_t), intent(in) :: var_list integer, intent(in), optional :: nlo_type logical, intent(in), optional :: can_be_integrated type(string_t), dimension(:), allocatable :: prt_str_in type(string_t), dimension(:), allocatable :: prt_str_out class(prc_core_def_t), allocatable :: core_def type(string_t) :: method type(string_t) :: born_me_method type(string_t) :: real_tree_me_method type(string_t) :: loop_me_method type(string_t) :: correlation_me_method type(string_t) :: dglap_me_method integer :: i call msg_debug2 (D_CORE, "process_configuration_setup_component") allocate (prt_str_in (size (prt_in))) allocate (prt_str_out (size (prt_out))) forall (i = 1:size (prt_in)) prt_str_in(i) = prt_in(i)% get_name () forall (i = 1:size (prt_out)) prt_str_out(i) = prt_out(i)%get_name () method = var_list%get_sval (var_str ("$method")) if (present (nlo_type)) then select case (nlo_type) case (BORN) born_me_method = var_list%get_sval (var_str ("$born_me_method")) if (born_me_method /= var_str ("")) then method = born_me_method end if case (NLO_VIRTUAL) loop_me_method = var_list%get_sval (var_str ("$loop_me_method")) if (loop_me_method /= var_str ("")) then method = loop_me_method end if case (NLO_REAL) real_tree_me_method = & var_list%get_sval (var_str ("$real_tree_me_method")) if (real_tree_me_method /= var_str ("")) then method = real_tree_me_method end if case (NLO_DGLAP) dglap_me_method = & var_list%get_sval (var_str ("$dglap_me_method")) if (dglap_me_method /= var_str ("")) then method = dglap_me_method end if case (NLO_SUBTRACTION,NLO_MISMATCH) correlation_me_method = & var_list%get_sval (var_str ("$correlation_me_method")) if (correlation_me_method /= var_str ("")) then method = correlation_me_method end if case default end select end if call dispatch_core_def (core_def, prt_str_in, prt_str_out, & model, var_list, config%id, nlo_type, method) select type (core_def) class is (prc_external_def_t) if (present (can_be_integrated)) then call core_def%set_active_writer (can_be_integrated) else call msg_fatal ("Cannot decide if user-defined core is integrated!") end if end select call msg_debug2 (D_CORE, "import_component with method ", method) call config%entry%import_component (i_component, & n_out = size (prt_out), & prt_in = prt_in, & prt_out = prt_out, & method = method, & variant = core_def, & nlo_type = nlo_type, & can_be_integrated = can_be_integrated) end subroutine process_configuration_setup_component @ %def process_configuration_setup_component @ <>= procedure :: set_fixed_emitter => process_configuration_set_fixed_emitter <>= subroutine process_configuration_set_fixed_emitter (config, i, emitter) class(process_configuration_t), intent(inout) :: config integer, intent(in) :: i, emitter call config%entry%set_fixed_emitter (i, emitter) end subroutine process_configuration_set_fixed_emitter @ %def process_configuration_set_fixed_emitter @ <>= procedure :: set_coupling_powers => process_configuration_set_coupling_powers <>= subroutine process_configuration_set_coupling_powers (config, alpha_power, alphas_power) class(process_configuration_t), intent(inout) :: config integer, intent(in) :: alpha_power, alphas_power call config%entry%set_coupling_powers (alpha_power, alphas_power) end subroutine process_configuration_set_coupling_powers @ %def process_configuration_set_coupling_powers @ <>= procedure :: set_component_associations => & process_configuration_set_component_associations <>= subroutine process_configuration_set_component_associations & (config, i_list, remnant, use_real_finite, mismatch) class(process_configuration_t), intent(inout) :: config integer, dimension(:), intent(in) :: i_list logical, intent(in) :: remnant, use_real_finite, mismatch integer :: i_component do i_component = 1, config%entry%get_n_components () if (any (i_list == i_component)) then call config%entry%set_associated_components (i_component, & i_list, remnant, use_real_finite, mismatch) end if end do end subroutine process_configuration_set_component_associations @ %def process_configuration_set_component_associations @ Record a process configuration: append it to the currently selected process definition library. <>= procedure :: record => process_configuration_record <>= subroutine process_configuration_record (config, global) class(process_configuration_t), intent(inout) :: config type(rt_data_t), intent(inout) :: global if (associated (global%prclib)) then call global%prclib%open () call global%prclib%append (config%entry) if (config%num_id /= 0) then write (msg_buffer, "(5A,I0,A)") "Process library '", & char (global%prclib%get_name ()), & "': recorded process '", char (config%id), "' (", & config%num_id, ")" else write (msg_buffer, "(5A)") "Process library '", & char (global%prclib%get_name ()), & "': recorded process '", char (config%id), "'" end if call msg_message () else call msg_fatal ("Recording process '" // char (config%id) & // "': active process library undefined") end if end subroutine process_configuration_record @ %def process_configuration_record @ \subsection{Unit Tests} Test module, followed by the corresponding implementation module. <<[[process_configurations_ut.f90]]>>= <> module process_configurations_ut use unit_tests use process_configurations_uti <> <> <> contains <> end module process_configurations_ut @ %def process_configurations_ut @ <<[[process_configurations_uti.f90]]>>= <> module process_configurations_uti <> use particle_specifiers, only: new_prt_spec use prclib_stacks use models use rt_data use process_configurations <> <> <> contains <> <> end module process_configurations_uti @ %def process_configurations_uti @ API: driver for the unit tests below. <>= public :: process_configurations_test <>= subroutine process_configurations_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine process_configurations_test @ %def process_configurations_test @ \subsubsection{Minimal setup} The workflow for setting up a minimal process configuration with the test matrix element method. We wrap this in a public procedure, so we can reuse it in later modules. The procedure prepares a process definition list for two processes (one [[prc_test]] and one [[omega]] type) and appends this to the process library stack in the global data set. The [[mode]] argument determines which processes to build. The [[procname]] argument replaces the predefined procname(s). This is re-exported by the UT module. <>= public :: prepare_test_library <>= subroutine prepare_test_library (global, libname, mode, procname) type(rt_data_t), intent(inout), target :: global type(string_t), intent(in) :: libname integer, intent(in) :: mode type(string_t), intent(in), dimension(:), optional :: procname type(prclib_entry_t), pointer :: lib type(string_t) :: prc_name type(string_t), dimension(:), allocatable :: prt_in, prt_out integer :: n_components type(process_configuration_t) :: prc_config if (.not. associated (global%prclib_stack%get_first_ptr ())) then allocate (lib) call lib%init (libname) call global%add_prclib (lib) end if if (btest (mode, 0)) then call global%select_model (var_str ("Test")) if (present (procname)) then prc_name = procname(1) else prc_name = "prc_config_a" end if n_components = 1 allocate (prt_in (2), prt_out (2)) prt_in = [var_str ("s"), var_str ("s")] prt_out = [var_str ("s"), var_str ("s")] call global%set_string (var_str ("$method"),& var_str ("unit_test"), is_known = .true.) call prc_config%init (prc_name, & size (prt_in), n_components, & global%model, global%var_list) call prc_config%setup_component (1, & new_prt_spec (prt_in), new_prt_spec (prt_out), & global%model, global%var_list) call prc_config%record (global) deallocate (prt_in, prt_out) end if if (btest (mode, 1)) then call global%select_model (var_str ("QED")) if (present (procname)) then prc_name = procname(2) else prc_name = "prc_config_b" end if n_components = 1 allocate (prt_in (2), prt_out (2)) prt_in = [var_str ("e+"), var_str ("e-")] prt_out = [var_str ("m+"), var_str ("m-")] call global%set_string (var_str ("$method"),& var_str ("omega"), is_known = .true.) call prc_config%init (prc_name, & size (prt_in), n_components, & global%model, global%var_list) call prc_config%setup_component (1, & new_prt_spec (prt_in), new_prt_spec (prt_out), & global%model, global%var_list) call prc_config%record (global) deallocate (prt_in, prt_out) end if if (btest (mode, 2)) then call global%select_model (var_str ("Test")) if (present (procname)) then prc_name = procname(1) else prc_name = "prc_config_a" end if n_components = 1 allocate (prt_in (1), prt_out (2)) prt_in = [var_str ("s")] prt_out = [var_str ("f"), var_str ("fbar")] call global%set_string (var_str ("$method"),& var_str ("unit_test"), is_known = .true.) call prc_config%init (prc_name, & size (prt_in), n_components, & global%model, global%var_list) call prc_config%setup_component (1, & new_prt_spec (prt_in), new_prt_spec (prt_out), & global%model, global%var_list) call prc_config%record (global) deallocate (prt_in, prt_out) end if end subroutine prepare_test_library @ %def prepare_test_library @ The actual test: the previous procedure with some prelude and postlude. In the global variable list, just before printing we reset the variables where the value may depend on the system and run environment. <>= call test (process_configurations_1, "process_configurations_1", & "test processes", & u, results) <>= public :: process_configurations_1 <>= subroutine process_configurations_1 (u) integer, intent(in) :: u type(rt_data_t), target :: global write (u, "(A)") "* Test output: process_configurations_1" write (u, "(A)") "* Purpose: configure test processes" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) write (u, "(A)") "* Configure processes as prc_test, model Test" write (u, "(A)") "* and omega, model QED" write (u, *) call global%set_int (var_str ("process_num_id"), & 42, is_known = .true.) call prepare_test_library (global, var_str ("prc_config_lib_1"), 3) global%os_data%fc = "Fortran-compiler" global%os_data%fcflags = "Fortran-flags" call global%write_libraries (u) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: process_configurations_1" end subroutine process_configurations_1 @ %def process_configurations_1 @ \subsubsection{\oMega\ options} Slightly extended example where we pass \oMega\ options to the library. The [[prepare_test_library]] contents are spelled out. <>= call test (process_configurations_2, "process_configurations_2", & "omega options", & u, results) <>= public :: process_configurations_2 <>= subroutine process_configurations_2 (u) integer, intent(in) :: u type(rt_data_t), target :: global type(string_t) :: libname type(prclib_entry_t), pointer :: lib type(string_t) :: prc_name type(string_t), dimension(:), allocatable :: prt_in, prt_out integer :: n_components type(process_configuration_t) :: prc_config write (u, "(A)") "* Test output: process_configurations_2" write (u, "(A)") "* Purpose: configure test processes with options" write (u, "(A)") call syntax_model_file_init () call global%global_init () write (u, "(A)") "* Configure processes as omega, model QED" write (u, *) libname = "prc_config_lib_2" allocate (lib) call lib%init (libname) call global%add_prclib (lib) call global%select_model (var_str ("QED")) prc_name = "prc_config_c" n_components = 2 allocate (prt_in (2), prt_out (2)) prt_in = [var_str ("e+"), var_str ("e-")] prt_out = [var_str ("m+"), var_str ("m-")] call global%set_string (var_str ("$method"),& var_str ("omega"), is_known = .true.) call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call prc_config%init (prc_name, size (prt_in), n_components, & global%model, global%var_list) call global%set_log (var_str ("?report_progress"), & .true., is_known = .true.) call prc_config%setup_component (1, & new_prt_spec (prt_in), new_prt_spec (prt_out), global%model, global%var_list) call global%set_log (var_str ("?report_progress"), & .false., is_known = .true.) call global%set_log (var_str ("?omega_openmp"), & .true., is_known = .true.) call global%set_string (var_str ("$restrictions"),& var_str ("3+4~A"), is_known = .true.) call global%set_string (var_str ("$omega_flags"), & var_str ("-fusion:progress_file omega_prc_config.log"), & is_known = .true.) call prc_config%setup_component (2, & new_prt_spec (prt_in), new_prt_spec (prt_out), global%model, global%var_list) call prc_config%record (global) deallocate (prt_in, prt_out) global%os_data%fc = "Fortran-compiler" global%os_data%fcflags = "Fortran-flags" call global%write_vars (u, [ & var_str ("$model_name"), & var_str ("$method"), & var_str ("?report_progress"), & var_str ("$restrictions"), & var_str ("$omega_flags")]) write (u, "(A)") call global%write_libraries (u) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: process_configurations_2" end subroutine process_configurations_2 @ %def process_configurations_2 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Compilation} This module manages compilation and loading of of process libraries. It is needed as a separate module because integration depends on it. <<[[compilations.f90]]>>= <> module compilations <> use io_units use system_defs, only: TAB use diagnostics use os_interface use variables, only: var_list_t use model_data use process_libraries use prclib_stacks use rt_data <> <> <> <> contains <> end module compilations @ %def compilations @ \subsection{The data type} The compilation item handles the compilation and loading of a single process library. <>= public :: compilation_item_t <>= type :: compilation_item_t private type(string_t) :: libname type(string_t) :: static_external_tag type(process_library_t), pointer :: lib => null () logical :: recompile_library = .false. logical :: verbose = .false. logical :: use_workspace = .false. type(string_t) :: workspace contains <> end type compilation_item_t @ %def compilation_item_t @ Initialize. Set flags and global properties of the library. Establish the workspace name, if defined. <>= procedure :: init => compilation_item_init <>= subroutine compilation_item_init (comp, libname, stack, var_list) class(compilation_item_t), intent(out) :: comp type(string_t), intent(in) :: libname type(prclib_stack_t), intent(inout) :: stack type(var_list_t), intent(in) :: var_list comp%libname = libname comp%lib => stack%get_library_ptr (comp%libname) if (.not. associated (comp%lib)) then call msg_fatal ("Process library '" // char (comp%libname) & // "' has not been declared.") end if comp%recompile_library = & var_list%get_lval (var_str ("?recompile_library")) comp%verbose = & var_list%get_lval (var_str ("?me_verbose")) comp%use_workspace = & var_list%is_known (var_str ("$compile_workspace")) if (comp%use_workspace) then comp%workspace = & var_list%get_sval (var_str ("$compile_workspace")) if (comp%workspace == "") comp%use_workspace = .false. else comp%workspace = "" end if end subroutine compilation_item_init @ %def compilation_item_init @ Compile the current library. The [[force]] flag has the effect that we first delete any previous files, as far as accessible by the current makefile. It also guarantees that previous files not accessible by a makefile will be overwritten. <>= procedure :: compile => compilation_item_compile <>= subroutine compilation_item_compile (comp, model, os_data, force, recompile) class(compilation_item_t), intent(inout) :: comp class(model_data_t), intent(in), target :: model type(os_data_t), intent(in) :: os_data logical, intent(in) :: force, recompile if (associated (comp%lib)) then if (comp%use_workspace) call setup_workspace (comp%workspace, os_data) call msg_message ("Process library '" & // char (comp%libname) // "': compiling ...") call comp%lib%configure (os_data) if (signal_is_pending ()) return call comp%lib%compute_md5sum (model) call comp%lib%write_makefile & (os_data, force, verbose=comp%verbose, workspace=comp%workspace) if (signal_is_pending ()) return if (force) then call comp%lib%clean & (os_data, distclean = .false., workspace=comp%workspace) if (signal_is_pending ()) return end if call comp%lib%write_driver (force, workspace=comp%workspace) if (signal_is_pending ()) return if (recompile) then call comp%lib%load & (os_data, keep_old_source = .true., workspace=comp%workspace) if (signal_is_pending ()) return end if call comp%lib%update_status (os_data, workspace=comp%workspace) end if end subroutine compilation_item_compile @ %def compilation_item_compile @ The workspace directory is created if it does not exist. (Applies only if the use has set the workspace directory.) <>= character(*), parameter :: ALLOWED_IN_DIRNAME = & "abcdefghijklmnopqrstuvwxyz& &ABCDEFGHIJKLMNOPQRSTUVWXYZ& &1234567890& &.,_-+=" @ %def ALLOWED_IN_DIRNAME <>= subroutine setup_workspace (workspace, os_data) type(string_t), intent(in) :: workspace type(os_data_t), intent(in) :: os_data if (verify (workspace, ALLOWED_IN_DIRNAME) == 0) then call msg_message ("Compile: preparing workspace directory '" & // char (workspace) // "'") call os_system_call ("mkdir -p '" // workspace // "'") else call msg_fatal ("compile: workspace name '" & // char (workspace) // "' contains illegal characters") end if end subroutine setup_workspace @ %def setup_workspace @ Load the current library, just after compiling it. <>= procedure :: load => compilation_item_load <>= subroutine compilation_item_load (comp, os_data) class(compilation_item_t), intent(inout) :: comp type(os_data_t), intent(in) :: os_data if (associated (comp%lib)) then call comp%lib%load (os_data, workspace=comp%workspace) end if end subroutine compilation_item_load @ %def compilation_item_load @ Message as a separate call: <>= procedure :: success => compilation_item_success <>= subroutine compilation_item_success (comp) class(compilation_item_t), intent(in) :: comp if (associated (comp%lib)) then call msg_message ("Process library '" // char (comp%libname) & // "': ... success.") else call msg_fatal ("Process library '" // char (comp%libname) & // "': ... failure.") end if end subroutine compilation_item_success @ %def compilation_item_success @ %def compilation_item_failure @ \subsection{API for library compilation and loading} This is a shorthand for compiling and loading a single library. The [[compilation_item]] object is used only internally. The [[global]] data set may actually be local to the caller. The compilation affects the library specified by its name if it is on the stack, but it does not reset the currently selected library. <>= public :: compile_library <>= subroutine compile_library (libname, global) type(string_t), intent(in) :: libname type(rt_data_t), intent(inout), target :: global type(compilation_item_t) :: comp logical :: force, recompile force = & global%var_list%get_lval (var_str ("?rebuild_library")) recompile = & global%var_list%get_lval (var_str ("?recompile_library")) if (associated (global%model)) then call comp%init (libname, global%prclib_stack, global%var_list) call comp%compile (global%model, global%os_data, force, recompile) if (signal_is_pending ()) return call comp%load (global%os_data) if (signal_is_pending ()) return else call msg_fatal ("Process library compilation: " & // " model is undefined.") end if call comp%success () end subroutine compile_library @ %def compile_library @ \subsection{Compiling static executable} This object handles the creation of a static executable which should contain a set of static process libraries. <>= public :: compilation_t <>= type :: compilation_t private type(string_t) :: exe_name type(string_t), dimension(:), allocatable :: lib_name contains <> end type compilation_t @ %def compilation_t @ Output. <>= procedure :: write => compilation_write <>= subroutine compilation_write (object, unit) class(compilation_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1x,A)") "Compilation object:" write (u, "(3x,3A)") "executable = '", & char (object%exe_name), "'" write (u, "(3x,A)", advance="no") "process libraries =" do i = 1, size (object%lib_name) write (u, "(1x,3A)", advance="no") "'", char (object%lib_name(i)), "'" end do write (u, *) end subroutine compilation_write @ %def compilation_write @ Initialize: we know the names of the executable and of the libraries. Optionally, we may provide a workspace directory. <>= procedure :: init => compilation_init <>= subroutine compilation_init (compilation, exe_name, lib_name) class(compilation_t), intent(out) :: compilation type(string_t), intent(in) :: exe_name type(string_t), dimension(:), intent(in) :: lib_name compilation%exe_name = exe_name allocate (compilation%lib_name (size (lib_name))) compilation%lib_name = lib_name end subroutine compilation_init @ %def compilation_init @ Write the dispatcher subroutine for the compiled libraries. Also write a subroutine which returns the names of the compiled libraries. <>= procedure :: write_dispatcher => compilation_write_dispatcher <>= subroutine compilation_write_dispatcher (compilation) class(compilation_t), intent(in) :: compilation type(string_t) :: file integer :: u, i file = compilation%exe_name // "_prclib_dispatcher.f90" call msg_message ("Static executable '" // char (compilation%exe_name) & // "': writing library dispatcher") u = free_unit () open (u, file = char (file), status="replace", action="write") write (u, "(3A)") "! Whizard: process libraries for executable '", & char (compilation%exe_name), "'" write (u, "(A)") "! Automatically generated file, do not edit" write (u, "(A)") "subroutine dispatch_prclib_static " // & "(driver, basename, modellibs_ldflags)" write (u, "(A)") " use iso_varying_string, string_t => varying_string" write (u, "(A)") " use prclib_interfaces" do i = 1, size (compilation%lib_name) associate (lib_name => compilation%lib_name(i)) write (u, "(A)") " use " // char (lib_name) // "_driver" end associate end do write (u, "(A)") " implicit none" write (u, "(A)") " class(prclib_driver_t), intent(inout), allocatable & &:: driver" write (u, "(A)") " type(string_t), intent(in) :: basename" write (u, "(A)") " logical, intent(in), optional :: " // & "modellibs_ldflags" write (u, "(A)") " select case (char (basename))" do i = 1, size (compilation%lib_name) associate (lib_name => compilation%lib_name(i)) write (u, "(3A)") " case ('", char (lib_name), "')" write (u, "(3A)") " allocate (", char (lib_name), "_driver_t & &:: driver)" end associate end do write (u, "(A)") " end select" write (u, "(A)") "end subroutine dispatch_prclib_static" write (u, *) write (u, "(A)") "subroutine get_prclib_static (libname)" write (u, "(A)") " use iso_varying_string, string_t => varying_string" write (u, "(A)") " implicit none" write (u, "(A)") " type(string_t), dimension(:), intent(inout), & &allocatable :: libname" write (u, "(A,I0,A)") " allocate (libname (", & size (compilation%lib_name), "))" do i = 1, size (compilation%lib_name) associate (lib_name => compilation%lib_name(i)) write (u, "(A,I0,A,A,A)") " libname(", i, ") = '", & char (lib_name), "'" end associate end do write (u, "(A)") "end subroutine get_prclib_static" close (u) end subroutine compilation_write_dispatcher @ %def compilation_write_dispatcher @ Write the Makefile subroutine for the compiled libraries. <>= procedure :: write_makefile => compilation_write_makefile <>= subroutine compilation_write_makefile & (compilation, os_data, ext_libtag, verbose) class(compilation_t), intent(in) :: compilation type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose type(string_t), intent(in), optional :: ext_libtag type(string_t) :: file, ext_tag integer :: u, i if (present (ext_libtag)) then ext_tag = ext_libtag else ext_tag = "" end if file = compilation%exe_name // ".makefile" call msg_message ("Static executable '" // char (compilation%exe_name) & // "': writing makefile") u = free_unit () open (u, file = char (file), status="replace", action="write") write (u, "(3A)") "# WHIZARD: Makefile for executable '", & char (compilation%exe_name), "'" write (u, "(A)") "# Automatically generated file, do not edit" write (u, "(A)") "" write (u, "(A)") "# Executable name" write (u, "(A)") "EXE = " // char (compilation%exe_name) write (u, "(A)") "" write (u, "(A)") "# Compiler" write (u, "(A)") "FC = " // char (os_data%fc) write (u, "(A)") "" write (u, "(A)") "# Included libraries" write (u, "(A)") "FCINCL = " // char (os_data%whizard_includes) write (u, "(A)") "" write (u, "(A)") "# Compiler flags" write (u, "(A)") "FCFLAGS = " // char (os_data%fcflags) write (u, "(A)") "LDFLAGS = " // char (os_data%ldflags) write (u, "(A)") "LDFLAGS_STATIC = " // char (os_data%ldflags_static) write (u, "(A)") "LDFLAGS_HEPMC = " // char (os_data%ldflags_hepmc) write (u, "(A)") "LDFLAGS_LCIO = " // char (os_data%ldflags_lcio) write (u, "(A)") "LDFLAGS_HOPPET = " // char (os_data%ldflags_hoppet) write (u, "(A)") "LDFLAGS_LOOPTOOLS = " // char (os_data%ldflags_looptools) write (u, "(A)") "LDWHIZARD = " // char (os_data%whizard_ldflags) write (u, "(A)") "" write (u, "(A)") "# Libtool" write (u, "(A)") "LIBTOOL = " // char (os_data%whizard_libtool) if (verbose) then write (u, "(A)") "FCOMPILE = $(LIBTOOL) --tag=FC --mode=compile" write (u, "(A)") "LINK = $(LIBTOOL) --tag=FC --mode=link" else write (u, "(A)") "FCOMPILE = @$(LIBTOOL) --silent --tag=FC --mode=compile" write (u, "(A)") "LINK = @$(LIBTOOL) --silent --tag=FC --mode=link" end if write (u, "(A)") "" write (u, "(A)") "# Compile commands (default)" write (u, "(A)") "LTFCOMPILE = $(FCOMPILE) $(FC) -c $(FCINCL) $(FCFLAGS)" write (u, "(A)") "" write (u, "(A)") "# Default target" write (u, "(A)") "all: link" write (u, "(A)") "" write (u, "(A)") "# Libraries" do i = 1, size (compilation%lib_name) associate (lib_name => compilation%lib_name(i)) write (u, "(A)") "LIBRARIES += " // char (lib_name) // ".la" write (u, "(A)") char (lib_name) // ".la:" write (u, "(A)") TAB // "$(MAKE) -f " // char (lib_name) // ".makefile" end associate end do write (u, "(A)") "" write (u, "(A)") "# Library dispatcher" write (u, "(A)") "DISP = $(EXE)_prclib_dispatcher" write (u, "(A)") "$(DISP).lo: $(DISP).f90 $(LIBRARIES)" if (.not. verbose) then write (u, "(A)") TAB // '@echo " FC " $@' end if write (u, "(A)") TAB // "$(LTFCOMPILE) $<" write (u, "(A)") "" write (u, "(A)") "# Executable" write (u, "(A)") "$(EXE): $(DISP).lo $(LIBRARIES)" if (.not. verbose) then write (u, "(A)") TAB // '@echo " FCLD " $@' end if write (u, "(A)") TAB // "$(LINK) $(FC) -static-libtool-libs $(FCFLAGS) \" write (u, "(A)") TAB // " $(LDWHIZARD) $(LDFLAGS) \" write (u, "(A)") TAB // " -o $(EXE) $^ \" write (u, "(A)") TAB // " $(LDFLAGS_HEPMC) $(LDFLAGS_LCIO) $(LDFLAGS_HOPPET) \" write (u, "(A)") TAB // " $(LDFLAGS_LOOPTOOLS) $(LDFLAGS_STATIC)" // char (ext_tag) write (u, "(A)") "" write (u, "(A)") "# Main targets" write (u, "(A)") "link: compile $(EXE)" write (u, "(A)") "compile: $(LIBRARIES) $(DISP).lo" write (u, "(A)") ".PHONY: link compile" write (u, "(A)") "" write (u, "(A)") "# Cleanup targets" write (u, "(A)") "clean-exe:" write (u, "(A)") TAB // "rm -f $(EXE)" write (u, "(A)") "clean-objects:" write (u, "(A)") TAB // "rm -f $(DISP).lo" write (u, "(A)") "clean-source:" write (u, "(A)") TAB // "rm -f $(DISP).f90" write (u, "(A)") "clean-makefile:" write (u, "(A)") TAB // "rm -f $(EXE).makefile" write (u, "(A)") "" write (u, "(A)") "clean: clean-exe clean-objects clean-source" write (u, "(A)") "distclean: clean clean-makefile" write (u, "(A)") ".PHONY: clean distclean" close (u) end subroutine compilation_write_makefile @ %def compilation_write_makefile @ Compile the dispatcher source code. <>= procedure :: make_compile => compilation_make_compile <>= subroutine compilation_make_compile (compilation, os_data) class(compilation_t), intent(in) :: compilation type(os_data_t), intent(in) :: os_data call os_system_call ("make compile " // os_data%makeflags & // " -f " // compilation%exe_name // ".makefile") end subroutine compilation_make_compile @ %def compilation_make_compile @ Link the dispatcher together with all matrix-element code and the \whizard\ and \oMega\ main libraries, to generate a static executable. <>= procedure :: make_link => compilation_make_link <>= subroutine compilation_make_link (compilation, os_data) class(compilation_t), intent(in) :: compilation type(os_data_t), intent(in) :: os_data call os_system_call ("make link " // os_data%makeflags & // " -f " // compilation%exe_name // ".makefile") end subroutine compilation_make_link @ %def compilation_make_link @ Cleanup. <>= procedure :: make_clean_exe => compilation_make_clean_exe <>= subroutine compilation_make_clean_exe (compilation, os_data) class(compilation_t), intent(in) :: compilation type(os_data_t), intent(in) :: os_data call os_system_call ("make clean-exe " // os_data%makeflags & // " -f " // compilation%exe_name // ".makefile") end subroutine compilation_make_clean_exe @ %def compilation_make_clean_exe @ \subsection{API for executable compilation} This is a shorthand for compiling and loading an executable, including the enclosed libraries. The [[compilation]] object is used only internally. The [[global]] data set may actually be local to the caller. The compilation affects the library specified by its name if it is on the stack, but it does not reset the currently selected library. <>= public :: compile_executable <>= subroutine compile_executable (exename, libname, global) type(string_t), intent(in) :: exename type(string_t), dimension(:), intent(in) :: libname type(rt_data_t), intent(inout), target :: global type(compilation_t) :: compilation type(compilation_item_t) :: item type(string_t) :: ext_libtag logical :: force, recompile, verbose integer :: i ext_libtag = "" force = & global%var_list%get_lval (var_str ("?rebuild_library")) recompile = & global%var_list%get_lval (var_str ("?recompile_library")) verbose = & global%var_list%get_lval (var_str ("?me_verbose")) call compilation%init (exename, [libname]) if (signal_is_pending ()) return call compilation%write_dispatcher () if (signal_is_pending ()) return do i = 1, size (libname) call item%init (libname(i), global%prclib_stack, global%var_list) call item%compile (global%model, global%os_data, & force=force, recompile=recompile) ext_libtag = "" // item%lib%get_static_modelname (global%os_data) if (signal_is_pending ()) return call item%success () end do call compilation%write_makefile & (global%os_data, ext_libtag=ext_libtag, verbose=verbose) if (signal_is_pending ()) return call compilation%make_compile (global%os_data) if (signal_is_pending ()) return call compilation%make_link (global%os_data) end subroutine compile_executable @ %def compile_executable @ \subsection{Unit Tests} Test module, followed by the stand-alone unit-test procedures. <<[[compilations_ut.f90]]>>= <> module compilations_ut use unit_tests use compilations_uti <> <> contains <> end module compilations_ut @ %def compilations_ut @ <<[[compilations_uti.f90]]>>= <> module compilations_uti <> use io_units use models use rt_data use process_configurations_ut, only: prepare_test_library use compilations <> <> contains <> end module compilations_uti @ %def compilations_uti @ API: driver for the unit tests below. <>= public :: compilations_test <>= subroutine compilations_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine compilations_test @ %def compilations_test @ \subsubsection{Intrinsic Matrix Element} Compile an intrinsic test matrix element ([[prc_test]] type). Note: In this and the following test, we reset the Fortran compiler and flag variables immediately before they are printed, so the test is portable. <>= call test (compilations_1, "compilations_1", & "intrinsic test processes", & u, results) <>= public :: compilations_1 <>= subroutine compilations_1 (u) integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global write (u, "(A)") "* Test output: compilations_1" write (u, "(A)") "* Purpose: configure and compile test process" write (u, "(A)") call syntax_model_file_init () call global%global_init () libname = "compilation_1" procname = "prc_comp_1" call prepare_test_library (global, libname, 1, [procname]) call compile_library (libname, global) call global%write_libraries (u) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: compilations_1" end subroutine compilations_1 @ %def compilations_1 @ \subsubsection{External Matrix Element} Compile an external test matrix element ([[omega]] type) <>= call test (compilations_2, "compilations_2", & "external process (omega)", & u, results) <>= public :: compilations_2 <>= subroutine compilations_2 (u) integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global write (u, "(A)") "* Test output: compilations_2" write (u, "(A)") "* Purpose: configure and compile test process" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) libname = "compilation_2" procname = "prc_comp_2" call prepare_test_library (global, libname, 2, [procname,procname]) call compile_library (libname, global) call global%write_libraries (u, libpath = .false.) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: compilations_2" end subroutine compilations_2 @ %def compilations_2 @ \subsubsection{External Matrix Element} Compile an external test matrix element ([[omega]] type) and create driver files for a static executable. <>= call test (compilations_3, "compilations_3", & "static executable: driver", & u, results) <>= public :: compilations_3 <>= subroutine compilations_3 (u) integer, intent(in) :: u type(string_t) :: libname, procname, exename type(rt_data_t), target :: global type(compilation_t) :: compilation integer :: u_file character(80) :: buffer write (u, "(A)") "* Test output: compilations_3" write (u, "(A)") "* Purpose: make static executable" write (u, "(A)") write (u, "(A)") "* Initialize library" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) libname = "compilations_3_lib" procname = "prc_comp_3" exename = "compilations_3" call prepare_test_library (global, libname, 2, [procname,procname]) call compilation%init (exename, [libname]) call compilation%write (u) write (u, "(A)") write (u, "(A)") "* Write dispatcher" write (u, "(A)") call compilation%write_dispatcher () u_file = free_unit () open (u_file, file = char (exename) // "_prclib_dispatcher.f90", & status = "old", action = "read") do read (u_file, "(A)", end = 1) buffer write (u, "(A)") trim (buffer) end do 1 close (u_file) write (u, "(A)") write (u, "(A)") "* Write Makefile" write (u, "(A)") associate (os_data => global%os_data) os_data%fc = "fortran-compiler" os_data%whizard_includes = "my-includes" os_data%fcflags = "my-fcflags" os_data%ldflags = "my-ldflags" os_data%ldflags_static = "my-ldflags-static" os_data%ldflags_hepmc = "my-ldflags-hepmc" os_data%ldflags_lcio = "my-ldflags-lcio" os_data%ldflags_hoppet = "my-ldflags-hoppet" os_data%ldflags_looptools = "my-ldflags-looptools" os_data%whizard_ldflags = "my-ldwhizard" os_data%whizard_libtool = "my-libtool" end associate call compilation%write_makefile (global%os_data, verbose = .true.) open (u_file, file = char (exename) // ".makefile", & status = "old", action = "read") do read (u_file, "(A)", end = 2) buffer write (u, "(A)") trim (buffer) end do 2 close (u_file) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: compilations_3" end subroutine compilations_3 @ %def compilations_3 @ \subsection{Test static build} The tests for building a static executable are separate, since they should be skipped if the \whizard\ build itself has static libraries disabled. <>= public :: compilations_static_test <>= subroutine compilations_static_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine compilations_static_test @ %def compilations_static_test @ \subsubsection{External Matrix Element} Compile an external test matrix element ([[omega]] type) and incorporate this in a new static WHIZARD executable. <>= call test (compilations_static_1, "compilations_static_1", & "static executable: compilation", & u, results) <>= public :: compilations_static_1 <>= subroutine compilations_static_1 (u) integer, intent(in) :: u type(string_t) :: libname, procname, exename type(rt_data_t), target :: global type(compilation_item_t) :: item type(compilation_t) :: compilation logical :: exist write (u, "(A)") "* Test output: compilations_static_1" write (u, "(A)") "* Purpose: make static executable" write (u, "(A)") write (u, "(A)") "* Initialize library" call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) libname = "compilations_static_1_lib" procname = "prc_comp_stat_1" exename = "compilations_static_1" call prepare_test_library (global, libname, 2, [procname,procname]) call compilation%init (exename, [libname]) write (u, "(A)") write (u, "(A)") "* Write dispatcher" call compilation%write_dispatcher () write (u, "(A)") write (u, "(A)") "* Write Makefile" call compilation%write_makefile (global%os_data, verbose = .true.) write (u, "(A)") write (u, "(A)") "* Build libraries" call item%init (libname, global%prclib_stack, global%var_list) call item%compile & (global%model, global%os_data, force=.true., recompile=.false.) call item%success () write (u, "(A)") write (u, "(A)") "* Check executable (should be absent)" write (u, "(A)") call compilation%make_clean_exe (global%os_data) inquire (file = char (exename), exist = exist) write (u, "(A,A,L1)") char (exename), " exists = ", exist write (u, "(A)") write (u, "(A)") "* Build executable" write (u, "(A)") call compilation%make_compile (global%os_data) call compilation%make_link (global%os_data) write (u, "(A)") "* Check executable (should be present)" write (u, "(A)") inquire (file = char (exename), exist = exist) write (u, "(A,A,L1)") char (exename), " exists = ", exist write (u, "(A)") write (u, "(A)") "* Cleanup" call compilation%make_clean_exe (global%os_data) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: compilations_static_1" end subroutine compilations_static_1 @ %def compilations_static_1 @ \subsubsection{External Matrix Element} Compile an external test matrix element ([[omega]] type) and incorporate this in a new static WHIZARD executable. In this version, we use the wrapper [[compile_executable]] procedure. <>= call test (compilations_static_2, "compilations_static_2", & "static executable: shortcut", & u, results) <>= public :: compilations_static_2 <>= subroutine compilations_static_2 (u) integer, intent(in) :: u type(string_t) :: libname, procname, exename type(rt_data_t), target :: global logical :: exist integer :: u_file write (u, "(A)") "* Test output: compilations_static_2" write (u, "(A)") "* Purpose: make static executable" write (u, "(A)") write (u, "(A)") "* Initialize library and compile" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) libname = "compilations_static_2_lib" procname = "prc_comp_stat_2" exename = "compilations_static_2" call prepare_test_library (global, libname, 2, [procname,procname]) call compile_executable (exename, [libname], global) write (u, "(A)") "* Check executable (should be present)" write (u, "(A)") inquire (file = char (exename), exist = exist) write (u, "(A,A,L1)") char (exename), " exists = ", exist write (u, "(A)") write (u, "(A)") "* Cleanup" u_file = free_unit () open (u_file, file = char (exename), status = "old", action = "write") close (u_file, status = "delete") call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: compilations_static_2" end subroutine compilations_static_2 @ %def compilations_static_2 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Integration} This module manages phase space setup, matrix-element evaluation and integration, as far as it is not done by lower-level routines, in particular in the [[processes]] module. <<[[integrations.f90]]>>= <> module integrations <> <> use io_units use diagnostics use os_interface use cputime use sm_qcd use physics_defs use model_data use pdg_arrays use variables, only: var_list_t use eval_trees use sf_mappings use sf_base use phs_base use rng_base use mci_base use process_libraries use prc_core use process_config, only: COMP_MASTER, COMP_REAL_FIN, & COMP_MISMATCH, COMP_PDF, COMP_REAL, COMP_SUB, COMP_VIRT, & COMP_REAL_SING use process use pcm_base, only: pcm_t use instances use process_stacks use models use iterations use rt_data use dispatch_me_methods, only: dispatch_core use dispatch_beams, only: dispatch_qcd, sf_prop_t, dispatch_sf_config use dispatch_phase_space, only: dispatch_sf_channels use dispatch_phase_space, only: dispatch_phs use dispatch_mci, only: dispatch_mci_s, setup_grid_path use dispatch_transforms, only: dispatch_evt_shower_hook use compilations, only: compile_library use dispatch_fks, only: dispatch_fks_s use nlo_data <> <> <> <> contains <> end module integrations @ %def integrations @ \subsection{The integration type} This type holds all relevant data, the integration methods operates on this. In contrast to the [[simulation_t]] introduced later, the [[integration_t]] applies to a single process. <>= public :: integration_t <>= type :: integration_t private type(string_t) :: process_id type(string_t) :: run_id type(process_t), pointer :: process => null () logical :: rebuild_phs = .false. logical :: ignore_phs_mismatch = .false. logical :: phs_only = .false. logical :: process_has_me = .true. integer :: n_calls_test = 0 logical :: vis_history = .true. type(string_t) :: history_filename type(string_t) :: log_filename type(helicity_selection_t) :: helicity_selection logical :: use_color_factors = .false. logical :: has_beam_pol = .false. logical :: combined_integration = .false. type(iteration_multipliers_t) :: iteration_multipliers type(nlo_settings_t) :: nlo_settings contains <> end type integration_t @ %def integration_t @ @ \subsection{Initialization} Initialization, first part: Create a process entry. Push it on the stack if the [[global]] environment is supplied. <>= procedure :: create_process => integration_create_process <>= subroutine integration_create_process (intg, process_id, global) class(integration_t), intent(out) :: intg type(rt_data_t), intent(inout), optional, target :: global type(string_t), intent(in) :: process_id type(process_entry_t), pointer :: process_entry call msg_debug (D_CORE, "integration_create_process") intg%process_id = process_id if (present (global)) then allocate (process_entry) intg%process => process_entry%process_t call global%process_stack%push (process_entry) else allocate (process_t :: intg%process) end if end subroutine integration_create_process @ %def integration_create_process @ Initialization, second part: Initialize the process object, using the local environment. We allocate a RNG factory and a QCD object. We also fetch a pointer to the model that the process uses. The process initializer will create a snapshot of that model. This procedure does not modify the [[local]] stack directly. The intent(inout) attribute for the [[local]] data set is due to the random generator seed which may be incremented during initialization. NOTE: Changes to model parameters within the current context are respected only if the process model coincides with the current model. This is the usual case. If not, we read the model from the global model library, which has default parameters. To become more flexible, we should implement a local model library which records local changes to currently inactive models. <>= procedure :: init_process => integration_init_process <>= subroutine integration_init_process (intg, local) class(integration_t), intent(inout) :: intg type(rt_data_t), intent(inout), target :: local type(string_t) :: model_name type(model_t), pointer :: model class(model_data_t), pointer :: model_instance type(var_list_t), pointer :: var_list call msg_debug (D_CORE, "integration_init_process") if (.not. local%prclib%contains (intg%process_id)) then call msg_fatal ("Process '" // char (intg%process_id) // "' not found" & // " in library '" // char (local%prclib%get_name ()) // "'") return end if model_name = local%prclib%get_model_name (intg%process_id) if (local%get_sval (var_str ("$model_name")) == model_name) then model => local%model else model => local%model_list%get_model_ptr (model_name) end if var_list => local%get_var_list_ptr () call intg%process%init (intg%process_id, & local%prclib, & local%os_data, & model, & var_list, & local%beam_structure) intg%run_id = intg%process%get_run_id () end subroutine integration_init_process @ %def integration_init_process @ Initialization, third part: complete process configuration. <>= procedure :: setup_process => integration_setup_process <>= subroutine integration_setup_process (intg, local, verbose, init_only) class(integration_t), intent(inout) :: intg type(rt_data_t), intent(inout), target :: local logical, intent(in), optional :: verbose logical, intent(in), optional :: init_only type(var_list_t), pointer :: var_list class(mci_t), allocatable :: mci_template type(sf_config_t), dimension(:), allocatable :: sf_config type(sf_prop_t) :: sf_prop type(sf_channel_t), dimension(:), allocatable :: sf_channel type(phs_channel_collection_t) :: phs_channel_collection logical :: sf_trace logical :: verb, initialize_only type(string_t) :: sf_string type(string_t) :: workspace verb = .true.; if (present (verbose)) verb = verbose initialize_only = .false. if (present (init_only)) initialize_only = init_only call display_init_message (verb) var_list => local%get_var_list_ptr () call setup_log_and_history () associate (process => intg%process) call set_intg_parameters (process) call process%setup_cores (dispatch_core, & intg%helicity_selection, intg%use_color_factors, intg%has_beam_pol) call process%init_phs_config () call process%init_components () call process%record_inactive_components () intg%process_has_me = process%has_matrix_element () if (.not. intg%process_has_me) then call msg_warning ("Process '" & // char (intg%process_id) // "': matrix element vanishes") end if call setup_beams () call setup_structure_functions () workspace = var_list%get_sval (var_str ("$integrate_workspace")) if (workspace == "") then call process%configure_phs & (intg%rebuild_phs, & intg%ignore_phs_mismatch, & intg%combined_integration) else call setup_grid_path (workspace) call process%configure_phs & (intg%rebuild_phs, & intg%ignore_phs_mismatch, & intg%combined_integration, & workspace) end if call process%complete_pcm_setup () call process%prepare_blha_cores () call process%create_blha_interface () call process%prepare_any_external_code () call process%setup_terms (with_beams = intg%has_beam_pol) call process%check_masses () if (verb) then call process%write (screen = .true.) call process%print_phs_startup_message () end if if (intg%process_has_me) then if (size (sf_config) > 0) then call process%collect_channels (phs_channel_collection) else if (.not. initialize_only & .and. process%contains_trivial_component ()) then call msg_fatal ("Integrate: 2 -> 1 process can't be handled & &with fixed-energy beams") end if call dispatch_sf_channels & (sf_channel, sf_string, sf_prop, phs_channel_collection, & local%var_list, local%get_sqrts(), local%beam_structure) if (allocated (sf_channel)) then if (size (sf_channel) > 0) then call process%set_sf_channel (sf_channel) end if end if call phs_channel_collection%final () if (verb) call process%sf_startup_message (sf_string) end if call process%setup_mci (dispatch_mci_s) call setup_expressions () call process%compute_md5sum () end associate contains subroutine setup_log_and_history () if (intg%run_id /= "") then intg%history_filename = intg%process_id // "." // intg%run_id & // ".history" intg%log_filename = intg%process_id // "." // intg%run_id // ".log" else intg%history_filename = intg%process_id // ".history" intg%log_filename = intg%process_id // ".log" end if intg%vis_history = & var_list%get_lval (var_str ("?vis_history")) end subroutine setup_log_and_history subroutine set_intg_parameters (process) type(process_t), intent(in) :: process intg%n_calls_test = & var_list%get_ival (var_str ("n_calls_test")) intg%combined_integration = & var_list%get_lval (var_str ('?combined_nlo_integration')) & .and. process%is_nlo_calculation () intg%use_color_factors = & var_list%get_lval (var_str ("?read_color_factors")) intg%has_beam_pol = & local%beam_structure%has_polarized_beams () intg%helicity_selection = & local%get_helicity_selection () intg%rebuild_phs = & var_list%get_lval (var_str ("?rebuild_phase_space")) intg%ignore_phs_mismatch = & .not. var_list%get_lval (var_str ("?check_phs_file")) intg%phs_only = & var_list%get_lval (var_str ("?phs_only")) end subroutine set_intg_parameters subroutine display_init_message (verb) logical, intent(in) :: verb if (verb) then call msg_message ("Initializing integration for process " & // char (intg%process_id) // ":") if (intg%run_id /= "") & call msg_message ("Run ID = " // '"' // char (intg%run_id) // '"') end if end subroutine display_init_message subroutine setup_beams () real(default) :: sqrts logical :: decay_rest_frame sqrts = local%get_sqrts () decay_rest_frame = & var_list%get_lval (var_str ("?decay_rest_frame")) if (intg%process_has_me) then call intg%process%setup_beams_beam_structure & (local%beam_structure, sqrts, decay_rest_frame) end if if (verb .and. intg%process_has_me) then call intg%process%beams_startup_message & (beam_structure = local%beam_structure) end if end subroutine setup_beams subroutine setup_structure_functions () integer :: n_in type(pdg_array_t), dimension(:,:), allocatable :: pdg_prc type(string_t) :: sf_trace_file if (intg%process_has_me) then call intg%process%get_pdg_in (pdg_prc) else n_in = intg%process%get_n_in () allocate (pdg_prc (n_in, intg%process%get_n_components ())) pdg_prc = 0 end if call dispatch_sf_config (sf_config, sf_prop, local%beam_structure, & local%get_var_list_ptr (), local%var_list, & local%model, local%os_data, local%get_sqrts (), pdg_prc) sf_trace = & var_list%get_lval (var_str ("?sf_trace")) sf_trace_file = & var_list%get_sval (var_str ("$sf_trace_file")) if (sf_trace) then call intg%process%init_sf_chain (sf_config, sf_trace_file) else call intg%process%init_sf_chain (sf_config) end if end subroutine setup_structure_functions subroutine setup_expressions () type(eval_tree_factory_t) :: expr_factory if (associated (local%pn%cuts_lexpr)) then if (verb) call msg_message ("Applying user-defined cuts.") call expr_factory%init (local%pn%cuts_lexpr) call intg%process%set_cuts (expr_factory) else if (verb) call msg_warning ("No cuts have been defined.") end if if (associated (local%pn%scale_expr)) then if (verb) call msg_message ("Using user-defined general scale.") call expr_factory%init (local%pn%scale_expr) call intg%process%set_scale (expr_factory) end if if (associated (local%pn%fac_scale_expr)) then if (verb) call msg_message ("Using user-defined factorization scale.") call expr_factory%init (local%pn%fac_scale_expr) call intg%process%set_fac_scale (expr_factory) end if if (associated (local%pn%ren_scale_expr)) then if (verb) call msg_message ("Using user-defined renormalization scale.") call expr_factory%init (local%pn%ren_scale_expr) call intg%process%set_ren_scale (expr_factory) end if if (associated (local%pn%weight_expr)) then if (verb) call msg_message ("Using user-defined reweighting factor.") call expr_factory%init (local%pn%weight_expr) call intg%process%set_weight (expr_factory) end if end subroutine setup_expressions end subroutine integration_setup_process @ %def integration_setup_process @ \subsection{Integration} Integrate: do the final integration. Here, we do a multi-iteration integration. Again, we skip iterations that are already on file. Record the results in the global variable list. <>= procedure :: evaluate => integration_evaluate <>= subroutine integration_evaluate & (intg, process_instance, i_mci, pass, it_list, pacify) class(integration_t), intent(inout) :: intg type(process_instance_t), intent(inout), target :: process_instance integer, intent(in) :: i_mci integer, intent(in) :: pass type(iterations_list_t), intent(in) :: it_list logical, intent(in), optional :: pacify integer :: n_calls, n_it logical :: adapt_grids, adapt_weights, final n_it = it_list%get_n_it (pass) n_calls = it_list%get_n_calls (pass) adapt_grids = it_list%adapt_grids (pass) adapt_weights = it_list%adapt_weights (pass) final = pass == it_list%get_n_pass () call process_instance%integrate ( & i_mci, n_it, n_calls, adapt_grids, adapt_weights, & final, pacify) end subroutine integration_evaluate @ %def integration_evaluate @ In case the user has not provided a list of iterations, make a reasonable default. This can depend on the process. The usual approach is to define two distinct passes, one for adaptation and one for integration. <>= procedure :: make_iterations_list => integration_make_iterations_list <>= subroutine integration_make_iterations_list (intg, it_list) class(integration_t), intent(in) :: intg type(iterations_list_t), intent(out) :: it_list integer :: pass, n_pass integer, dimension(:), allocatable :: n_it, n_calls logical, dimension(:), allocatable :: adapt_grids, adapt_weights n_pass = intg%process%get_n_pass_default () allocate (n_it (n_pass), n_calls (n_pass)) allocate (adapt_grids (n_pass), adapt_weights (n_pass)) do pass = 1, n_pass n_it(pass) = intg%process%get_n_it_default (pass) n_calls(pass) = intg%process%get_n_calls_default (pass) adapt_grids(pass) = intg%process%adapt_grids_default (pass) adapt_weights(pass) = intg%process%adapt_weights_default (pass) end do call it_list%init (n_it, n_calls, & adapt_grids = adapt_grids, adapt_weights = adapt_weights) end subroutine integration_make_iterations_list @ %def integration_make_iterations_list @ In NLO calculations, the individual components might scale very differently with the number of calls. This especially applies to the real-subtracted component, which usually fluctuates more than the Born and virtual component, making it a bottleneck of the calculation. Thus, the calculation is throttled twice, first by the number of calls for the real component, second by the number of surplus calls of computation-intense virtual matrix elements. Therefore, we want to set a different number of calls for each component, which is done by the subroutine [[integration_apply_call_multipliers]]. <>= procedure :: init_iteration_multipliers => integration_init_iteration_multipliers <>= subroutine integration_init_iteration_multipliers (intg, local) class(integration_t), intent(inout) :: intg type(rt_data_t), intent(in) :: local integer :: n_pass, pass type(iterations_list_t) :: it_list n_pass = local%it_list%get_n_pass () if (n_pass == 0) then call intg%make_iterations_list (it_list) n_pass = it_list%get_n_pass () end if associate (it_multipliers => intg%iteration_multipliers) allocate (it_multipliers%n_calls0 (n_pass)) do pass = 1, n_pass it_multipliers%n_calls0(pass) = local%it_list%get_n_calls (pass) end do it_multipliers%mult_real = local%var_list%get_rval & (var_str ("mult_call_real")) it_multipliers%mult_virt = local%var_list%get_rval & (var_str ("mult_call_virt")) it_multipliers%mult_dglap = local%var_list%get_rval & (var_str ("mult_call_dglap")) end associate end subroutine integration_init_iteration_multipliers @ %def integration_init_iteration_multipliers @ <>= procedure :: apply_call_multipliers => integration_apply_call_multipliers <>= subroutine integration_apply_call_multipliers (intg, n_pass, i_component, it_list) class(integration_t), intent(in) :: intg integer, intent(in) :: n_pass, i_component type(iterations_list_t), intent(inout) :: it_list integer :: nlo_type integer :: n_calls0, n_calls integer :: pass real(default) :: multiplier nlo_type = intg%process%get_component_nlo_type (i_component) do pass = 1, n_pass associate (multipliers => intg%iteration_multipliers) select case (nlo_type) case (NLO_REAL) multiplier = multipliers%mult_real case (NLO_VIRTUAL) multiplier = multipliers%mult_virt case (NLO_DGLAP) multiplier = multipliers%mult_dglap case default return end select end associate if (n_pass <= size (intg%iteration_multipliers%n_calls0)) then n_calls0 = intg%iteration_multipliers%n_calls0 (pass) n_calls = floor (multiplier * n_calls0) call it_list%set_n_calls (pass, n_calls) end if end do end subroutine integration_apply_call_multipliers @ %def integration_apply_call_multipliers @ \subsection{API for integration objects} This initializer does everything except assigning cuts/scale/weight expressions. <>= procedure :: init => integration_init <>= subroutine integration_init & (intg, process_id, local, global, local_stack, init_only) class(integration_t), intent(out) :: intg type(string_t), intent(in) :: process_id type(rt_data_t), intent(inout), target :: local type(rt_data_t), intent(inout), optional, target :: global logical, intent(in), optional :: init_only logical, intent(in), optional :: local_stack logical :: use_local use_local = .false.; if (present (local_stack)) use_local = local_stack if (present (global)) then call intg%create_process (process_id, global) else if (use_local) then call intg%create_process (process_id, local) else call intg%create_process (process_id) end if call intg%init_process (local) call intg%setup_process (local, init_only = init_only) call intg%init_iteration_multipliers (local) end subroutine integration_init @ %def integration_init @ Do the integration for a single process, both warmup and final evaluation. The [[eff_reset]] flag is to suppress numerical noise in the graphical output of the integration history. <>= procedure :: integrate => integration_integrate <>= subroutine integration_integrate (intg, local, eff_reset) class(integration_t), intent(inout) :: intg type(rt_data_t), intent(in), target :: local logical, intent(in), optional :: eff_reset type(string_t) :: log_filename type(var_list_t), pointer :: var_list type(process_instance_t), allocatable, target :: process_instance type(iterations_list_t) :: it_list logical :: pacify integer :: pass, i_mci, n_mci, n_pass integer :: i_component integer :: nlo_type logical :: display_summed logical :: nlo_active type(string_t) :: component_output allocate (process_instance) call process_instance%init (intg%process) var_list => intg%process%get_var_list_ptr () call openmp_set_num_threads_verbose & (var_list%get_ival (var_str ("openmp_num_threads")), & var_list%get_lval (var_str ("?openmp_logging"))) pacify = var_list%get_lval (var_str ("?pacify")) display_summed = .true. n_mci = intg%process%get_n_mci () if (n_mci == 1) then write (msg_buffer, "(A,A,A)") & "Starting integration for process '", & char (intg%process%get_id ()), "'" call msg_message () end if call setup_hooks () nlo_active = any (intg%process%get_component_nlo_type & ([(i_mci, i_mci = 1, n_mci)]) /= BORN) do i_mci = 1, n_mci i_component = intg%process%get_master_component (i_mci) nlo_type = intg%process%get_component_nlo_type (i_component) if (intg%process%component_can_be_integrated (i_component)) then if (n_mci > 1) then if (nlo_active) then if (intg%combined_integration .and. nlo_type == BORN) then component_output = var_str ("Combined") else component_output = component_status (nlo_type) end if write (msg_buffer, "(A,A,A,A,A)") & "Starting integration for process '", & char (intg%process%get_id ()), "' part '", & char (component_output), "'" else write (msg_buffer, "(A,A,A,I0)") & "Starting integration for process '", & char (intg%process%get_id ()), "' part ", i_mci end if call msg_message () end if n_pass = local%it_list%get_n_pass () if (n_pass == 0) then call msg_message ("Integrate: iterations not specified, & &using default") call intg%make_iterations_list (it_list) n_pass = it_list%get_n_pass () else it_list = local%it_list end if call intg%apply_call_multipliers (n_pass, i_mci, it_list) call msg_message ("Integrate: " // char (it_list%to_string ())) do pass = 1, n_pass call intg%evaluate (process_instance, i_mci, pass, it_list, pacify) if (signal_is_pending ()) return end do call intg%process%final_integration (i_mci) if (intg%vis_history) then call intg%process%display_integration_history & (i_mci, intg%history_filename, local%os_data, eff_reset) end if if (local%logfile == intg%log_filename) then if (intg%run_id /= "") then log_filename = intg%process_id // "." // intg%run_id // & ".var.log" else log_filename = intg%process_id // ".var.log" end if call msg_message ("Name clash for global logfile and process log: ", & arr =[var_str ("| Renaming log file from ") // local%logfile, & var_str ("| to ") // log_filename // var_str (" .")]) else log_filename = intg%log_filename end if call intg%process%write_logfile (i_mci, log_filename) end if end do if (n_mci > 1 .and. display_summed) then call msg_message ("Integrate: sum of all components") call intg%process%display_summed_results (pacify) end if call process_instance%final () deallocate (process_instance) contains subroutine setup_hooks () class(process_instance_hook_t), pointer :: hook call dispatch_evt_shower_hook (hook, var_list, process_instance) if (associated (hook)) then call process_instance%append_after_hook (hook) end if end subroutine setup_hooks end subroutine integration_integrate @ %def integration_integrate @ Do a dummy integration for a process which could not be initialized (e.g., has no matrix element). The result is zero. <>= procedure :: integrate_dummy => integration_integrate_dummy <>= subroutine integration_integrate_dummy (intg) class(integration_t), intent(inout) :: intg call intg%process%integrate_dummy () end subroutine integration_integrate_dummy @ %def integration_integrate_dummy @ Just sample the matrix element under realistic conditions (but no cuts); throw away the results. <>= procedure :: sampler_test => integration_sampler_test <>= subroutine integration_sampler_test (intg) class(integration_t), intent(inout) :: intg type(process_instance_t), allocatable, target :: process_instance integer :: n_mci, i_mci type(timer_t) :: timer_mci, timer_tot real(default) :: t_mci, t_tot allocate (process_instance) call process_instance%init (intg%process) n_mci = intg%process%get_n_mci () if (n_mci == 1) then write (msg_buffer, "(A,A,A)") & "Test: probing process '", & char (intg%process%get_id ()), "'" call msg_message () end if call timer_tot%start () do i_mci = 1, n_mci if (n_mci > 1) then write (msg_buffer, "(A,A,A,I0)") & "Test: probing process '", & char (intg%process%get_id ()), "' part ", i_mci call msg_message () end if call timer_mci%start () call process_instance%sampler_test (i_mci, intg%n_calls_test) call timer_mci%stop () t_mci = timer_mci write (msg_buffer, "(A,ES12.5)") "Test: " & // "time in seconds (wallclock): ", t_mci call msg_message () end do call timer_tot%stop () t_tot = timer_tot if (n_mci > 1) then write (msg_buffer, "(A,ES12.5)") "Test: " & // "total time (wallclock): ", t_tot call msg_message () end if call process_instance%final () end subroutine integration_sampler_test @ %def integration_sampler_test @ Return the process pointer (needed by simulate): <>= procedure :: get_process_ptr => integration_get_process_ptr <>= function integration_get_process_ptr (intg) result (ptr) class(integration_t), intent(in) :: intg type(process_t), pointer :: ptr ptr => intg%process end function integration_get_process_ptr @ %def integration_get_process_ptr @ Simply integrate, do a dummy integration if necessary. The [[integration]] object exists only internally. If the [[global]] environment is provided, the process object is appended to the global stack. Otherwise, if [[local_stack]] is set, we append to the local process stack. If this is unset, the [[process]] object is not recorded permanently. The [[init_only]] flag can be used to skip the actual integration part. We will end up with a process object that is completely initialized, including phase space configuration. The [[eff_reset]] flag is to suppress numerical noise in the visualization of the integration history. <>= public :: integrate_process <>= subroutine integrate_process (process_id, local, global, local_stack, init_only, eff_reset) type(string_t), intent(in) :: process_id type(rt_data_t), intent(inout), target :: local type(rt_data_t), intent(inout), optional, target :: global logical, intent(in), optional :: local_stack, init_only, eff_reset type(string_t) :: prclib_name type(integration_t) :: intg character(32) :: buffer <> <> if (.not. associated (local%prclib)) then call msg_fatal ("Integrate: current process library is undefined") return end if if (.not. local%prclib%is_active ()) then call msg_message ("Integrate: current process library needs compilation") prclib_name = local%prclib%get_name () call compile_library (prclib_name, local) if (signal_is_pending ()) return call msg_message ("Integrate: compilation done") end if call intg%init (process_id, local, global, local_stack, init_only) if (signal_is_pending ()) return if (present (init_only)) then if (init_only) return end if if (intg%n_calls_test > 0) then write (buffer, "(I0)") intg%n_calls_test call msg_message ("Integrate: test (" // trim (buffer) // " calls) ...") call intg%sampler_test () call msg_message ("Integrate: ... test complete.") if (signal_is_pending ()) return end if <> if (intg%phs_only) then call msg_message ("Integrate: phase space only, skipping integration") else if (intg%process_has_me) then call intg%integrate (local, eff_reset) else call intg%integrate_dummy () end if end if end subroutine integrate_process @ %def integrate_process <>= @ <>= @ <>= @ @ The parallelization leads to undefined behavior while writing simultaneously to one file. The master worker has to initialize single-handed the corresponding library files and the phase space file. The slave worker will wait with a blocking [[MPI_BCAST]] until they receive a logical flag. <>= type(var_list_t), pointer :: var_list logical :: mpi_logging, process_init integer :: rank, n_size <>= call msg_debug (D_MPI, "integrate_process") var_list => local%get_var_list_ptr () process_init = .false. call mpi_get_comm_id (n_size, rank) mpi_logging = (("vamp2" == char (var_list%get_sval (var_str ("$integration_method"))) .and. & & (n_size > 1)) .or. var_list%get_lval (var_str ("?mpi_logging"))) call msg_debug (D_MPI, "n_size", rank) call msg_debug (D_MPI, "rank", rank) call msg_debug (D_MPI, "mpi_logging", mpi_logging) if (rank /= 0) then if (mpi_logging) then call msg_message ("MPI: wait for master to finish process initialization ...") end if call MPI_bcast (process_init, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD) else process_init = .true. end if if (process_init) then <>= if (rank == 0) then if (mpi_logging) then call msg_message ("MPI: finish process initialization, load slaves ...") end if call MPI_bcast (process_init, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD) end if end if call MPI_barrier (MPI_COMM_WORLD) call mpi_set_logging (mpi_logging) @ %def integrate_process_mpi @ \subsection{Unit Tests} Test module, followed by the stand-alone unit-test procedures. <<[[integrations_ut.f90]]>>= <> module integrations_ut use unit_tests use integrations_uti <> <> contains <> end module integrations_ut @ %def integrations_ut @ <<[[integrations_uti.f90]]>>= <> module integrations_uti <> <> use io_units use ifiles use lexers use parser use io_units use flavors use interactions, only: reset_interaction_counter use phs_forests use eval_trees use models use rt_data use process_configurations_ut, only: prepare_test_library use compilations, only: compile_library use integrations use phs_wood_ut, only: write_test_phs_file <> <> contains <> end module integrations_uti @ %def integrations_uti @ API: driver for the unit tests below. <>= public :: integrations_test <>= subroutine integrations_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine integrations_test @ %def integrations_test @ <>= public :: integrations_history_test <>= subroutine integrations_history_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine integrations_history_test @ %def integrations_history_test @ \subsubsection{Integration of test process} Compile and integrate an intrinsic test matrix element ([[prc_test]] type). The phase-space implementation is [[phs_single]] (single-particle phase space), the integrator is [[mci_midpoint]]. The cross section for the $2\to 2$ process $ss\to ss$ with its constant matrix element is given by \begin{equation} \sigma = c\times f\times \Phi_2 \times |M|^2. \end{equation} $c$ is the conversion constant \begin{equation} c = 0.3894\times 10^{12}\;\mathrm{fb}\,\mathrm{GeV}^2. \end{equation} $f$ is the flux of the incoming particles with mass $m=125\,\mathrm{GeV}$ and energy $\sqrt{s}=1000\,\mathrm{GeV}$ \begin{equation} f = \frac{(2\pi)^4}{2\lambda^{1/2}(s,m^2,m^2)} = \frac{(2\pi)^4}{2\sqrt{s}\,\sqrt{s - 4m^2}} = 8.048\times 10^{-4}\;\mathrm{GeV}^{-2} \end{equation} $\Phi_2$ is the volume of the two-particle phase space \begin{equation} \Phi_2 = \frac{1}{4(2\pi)^5} = 2.5529\times 10^{-5}. \end{equation} The squared matrix element $|M|^2$ is unity. Combining everything, we obtain \begin{equation} \sigma = 8000\;\mathrm{fb} \end{equation} This number should appear as the final result. Note: In this and the following test, we reset the Fortran compiler and flag variables immediately before they are printed, so the test is portable. <>= call test (integrations_1, "integrations_1", & "intrinsic test process", & u, results) <>= public :: integrations_1 <>= subroutine integrations_1 (u) integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global write (u, "(A)") "* Test output: integrations_1" write (u, "(A)") "* Purpose: integrate test process" write (u, "(A)") call syntax_model_file_init () call global%global_init () libname = "integration_1" procname = "prc_config_a" call prepare_test_library (global, libname, 1) call compile_library (libname, global) call global%set_string (var_str ("$run_id"), & var_str ("integrations1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([1], [1000]) call reset_interaction_counter () call integrate_process (procname, global, local_stack=.true.) call global%write (u, vars = [ & var_str ("$method"), & var_str ("sqrts"), & var_str ("$integration_method"), & var_str ("$phs_method"), & var_str ("$run_id")]) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: integrations_1" end subroutine integrations_1 @ %def integrations_1 @ \subsubsection{Integration with cuts} Compile and integrate an intrinsic test matrix element ([[prc_test]] type) with cuts set. <>= call test (integrations_2, "integrations_2", & "intrinsic test process with cut", & u, results) <>= public :: integrations_2 <>= subroutine integrations_2 (u) integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global type(string_t) :: cut_expr_text type(ifile_t) :: ifile type(stream_t) :: stream type(parse_tree_t) :: parse_tree type(string_t), dimension(0) :: empty_string_array write (u, "(A)") "* Test output: integrations_2" write (u, "(A)") "* Purpose: integrate test process with cut" write (u, "(A)") call syntax_model_file_init () call global%global_init () write (u, "(A)") "* Prepare a cut expression" write (u, "(A)") call syntax_pexpr_init () cut_expr_text = "all Pt > 100 [s]" call ifile_append (ifile, cut_expr_text) call stream_init (stream, ifile) call parse_tree_init_lexpr (parse_tree, stream, .true.) global%pn%cuts_lexpr => parse_tree%get_root_ptr () write (u, "(A)") "* Build and initialize a test process" write (u, "(A)") libname = "integration_3" procname = "prc_config_a" call prepare_test_library (global, libname, 1) call compile_library (libname, global) call global%set_string (var_str ("$run_id"), & var_str ("integrations1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([1], [1000]) call reset_interaction_counter () call integrate_process (procname, global, local_stack=.true.) call global%write (u, vars = empty_string_array) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: integrations_2" end subroutine integrations_2 @ %def integrations_2 @ \subsubsection{Standard phase space} Compile and integrate an intrinsic test matrix element ([[prc_test]] type) using the default ([[phs_wood]]) phase-space implementation. We use an explicit phase-space configuration file with a single channel and integrate by [[mci_midpoint]]. <>= call test (integrations_3, "integrations_3", & "standard phase space", & u, results) <>= public :: integrations_3 <>= subroutine integrations_3 (u) <> <> use interactions, only: reset_interaction_counter use models use rt_data use process_configurations_ut, only: prepare_test_library use compilations, only: compile_library use integrations implicit none integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global integer :: u_phs write (u, "(A)") "* Test output: integrations_3" write (u, "(A)") "* Purpose: integrate test process" write (u, "(A)") write (u, "(A)") "* Initialize process and parameters" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () call global%global_init () libname = "integration_3" procname = "prc_config_a" call prepare_test_library (global, libname, 1) call compile_library (libname, global) call global%set_string (var_str ("$run_id"), & var_str ("integrations1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("default"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?phs_s_mapping"),& .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) write (u, "(A)") "* Create a scratch phase-space file" write (u, "(A)") u_phs = free_unit () open (u_phs, file = "integrations_3.phs", & status = "replace", action = "write") call write_test_phs_file (u_phs, var_str ("prc_config_a_i1")) close (u_phs) call global%set_string (var_str ("$phs_file"),& var_str ("integrations_3.phs"), is_known = .true.) call global%it_list%init ([1], [1000]) write (u, "(A)") "* Integrate" write (u, "(A)") call reset_interaction_counter () call integrate_process (procname, global, local_stack=.true.) call global%write (u, vars = [ & var_str ("$phs_method"), & var_str ("$phs_file")]) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_phs_forest_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: integrations_3" end subroutine integrations_3 @ %def integrations_3 @ \subsubsection{VAMP integration} Compile and integrate an intrinsic test matrix element ([[prc_test]] type) using the single-channel ([[phs_single]]) phase-space implementation. The integration method is [[vamp]]. <>= call test (integrations_4, "integrations_4", & "VAMP integration (one iteration)", & u, results) <>= public :: integrations_4 <>= subroutine integrations_4 (u) integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global write (u, "(A)") "* Test output: integrations_4" write (u, "(A)") "* Purpose: integrate test process using VAMP" write (u, "(A)") write (u, "(A)") "* Initialize process and parameters" write (u, "(A)") call syntax_model_file_init () call global%global_init () libname = "integrations_4_lib" procname = "integrations_4" call prepare_test_library (global, libname, 1, [procname]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .false., is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([1], [1000]) write (u, "(A)") "* Integrate" write (u, "(A)") call reset_interaction_counter () call integrate_process (procname, global, local_stack=.true.) call global%pacify (efficiency_reset = .true., error_reset = .true.) call global%write (u, vars = [var_str ("$integration_method")], & pacify = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: integrations_4" end subroutine integrations_4 @ %def integrations_4 @ \subsubsection{Multiple iterations integration} Compile and integrate an intrinsic test matrix element ([[prc_test]] type) using the single-channel ([[phs_single]]) phase-space implementation. The integration method is [[vamp]]. We launch three iterations. <>= call test (integrations_5, "integrations_5", & "VAMP integration (three iterations)", & u, results) <>= public :: integrations_5 <>= subroutine integrations_5 (u) integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global write (u, "(A)") "* Test output: integrations_5" write (u, "(A)") "* Purpose: integrate test process using VAMP" write (u, "(A)") write (u, "(A)") "* Initialize process and parameters" write (u, "(A)") call syntax_model_file_init () call global%global_init () libname = "integrations_5_lib" procname = "integrations_5" call prepare_test_library (global, libname, 1, [procname]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .false., is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([3], [1000]) write (u, "(A)") "* Integrate" write (u, "(A)") call reset_interaction_counter () call integrate_process (procname, global, local_stack=.true.) call global%pacify (efficiency_reset = .true., error_reset = .true.) call global%write (u, vars = [var_str ("$integration_method")], & pacify = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: integrations_5" end subroutine integrations_5 @ %def integrations_5 @ \subsubsection{Multiple passes integration} Compile and integrate an intrinsic test matrix element ([[prc_test]] type) using the single-channel ([[phs_single]]) phase-space implementation. The integration method is [[vamp]]. We launch three passes with three iterations each. <>= call test (integrations_6, "integrations_6", & "VAMP integration (three passes)", & u, results) <>= public :: integrations_6 <>= subroutine integrations_6 (u) integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global type(string_t), dimension(0) :: no_vars write (u, "(A)") "* Test output: integrations_6" write (u, "(A)") "* Purpose: integrate test process using VAMP" write (u, "(A)") write (u, "(A)") "* Initialize process and parameters" write (u, "(A)") call syntax_model_file_init () call global%global_init () libname = "integrations_6_lib" procname = "integrations_6" call prepare_test_library (global, libname, 1, [procname]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .false., is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([3, 3, 3], [1000, 1000, 1000], & adapt = [.true., .true., .false.], & adapt_code = [var_str ("wg"), var_str ("g"), var_str ("")]) write (u, "(A)") "* Integrate" write (u, "(A)") call reset_interaction_counter () call integrate_process (procname, global, local_stack=.true.) call global%pacify (efficiency_reset = .true., error_reset = .true.) call global%write (u, vars = no_vars, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: integrations_6" end subroutine integrations_6 @ %def integrations_6 @ \subsubsection{VAMP and default phase space} Compile and integrate an intrinsic test matrix element ([[prc_test]] type) using the default ([[phs_wood]]) phase-space implementation. The integration method is [[vamp]]. We launch three passes with three iterations each. We enable channel equivalences and groves. <>= call test (integrations_7, "integrations_7", & "VAMP integration with wood phase space", & u, results) <>= public :: integrations_7 <>= subroutine integrations_7 (u) integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global type(string_t), dimension(0) :: no_vars integer :: iostat, u_phs character(95) :: buffer type(string_t) :: phs_file logical :: exist write (u, "(A)") "* Test output: integrations_7" write (u, "(A)") "* Purpose: integrate test process using VAMP" write (u, "(A)") write (u, "(A)") "* Initialize process and parameters" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () call global%global_init () libname = "integrations_7_lib" procname = "integrations_7" call prepare_test_library (global, libname, 1, [procname]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("wood"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .true., is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?phs_s_mapping"),& .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([3, 3, 3], [1000, 1000, 1000], & adapt = [.true., .true., .false.], & adapt_code = [var_str ("wg"), var_str ("g"), var_str ("")]) write (u, "(A)") "* Integrate" write (u, "(A)") call reset_interaction_counter () call integrate_process (procname, global, local_stack=.true.) call global%pacify (efficiency_reset = .true., error_reset = .true.) call global%write (u, vars = no_vars, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_phs_forest_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Generated phase-space file" write (u, "(A)") phs_file = procname // ".r1.i1.phs" inquire (file = char (phs_file), exist = exist) if (exist) then u_phs = free_unit () open (u_phs, file = char (phs_file), action = "read", status = "old") iostat = 0 do while (iostat == 0) read (u_phs, "(A)", iostat = iostat) buffer if (iostat == 0) write (u, "(A)") trim (buffer) end do close (u_phs) else write (u, "(A)") "[file is missing]" end if write (u, "(A)") write (u, "(A)") "* Test output end: integrations_7" end subroutine integrations_7 @ %def integrations_7 @ \subsubsection{Structure functions} Compile and integrate an intrinsic test matrix element ([[prc_test]] type) using the default ([[phs_wood]]) phase-space implementation. The integration method is [[vamp]]. There is a structure function of type [[unit_test]]. We use a test structure function $f(x)=x$ for both beams. Together with the $1/x_1x_2$ factor from the phase-space flux and a unit matrix element, we should get the same result as previously for the process without structure functions. There is a slight correction due to the $m_s$ mass which we set to zero here. <>= call test (integrations_8, "integrations_8", & "integration with structure function", & u, results) <>= public :: integrations_8 <>= subroutine integrations_8 (u) <> <> use interactions, only: reset_interaction_counter use phs_forests use models use rt_data use process_configurations_ut, only: prepare_test_library use compilations, only: compile_library use integrations implicit none integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global type(flavor_t) :: flv type(string_t) :: name write (u, "(A)") "* Test output: integrations_8" write (u, "(A)") "* Purpose: integrate test process using VAMP & &with structure function" write (u, "(A)") write (u, "(A)") "* Initialize process and parameters" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () call global%global_init () libname = "integrations_8_lib" procname = "integrations_8" call prepare_test_library (global, libname, 1, [procname]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("wood"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .true., is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?phs_s_mapping"),& .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%model_set_real (var_str ("ms"), 0._default) call reset_interaction_counter () call flv%init (25, global%model) name = flv%get_name () call global%beam_structure%init_sf ([name, name], [1]) call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1")) write (u, "(A)") "* Integrate" write (u, "(A)") call global%it_list%init ([1], [1000]) call integrate_process (procname, global, local_stack=.true.) call global%write (u, vars = [var_str ("ms")]) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_phs_forest_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: integrations_8" end subroutine integrations_8 @ %def integrations_8 @ \subsubsection{Integration with sign change} Compile and integrate an intrinsic test matrix element ([[prc_test]] type). The phase-space implementation is [[phs_single]] (single-particle phase space), the integrator is [[mci_midpoint]]. The weight that is applied changes the sign in half of phase space. The weight is $-3$ and $1$, respectively, so the total result is equal to the original, but negative sign. The efficiency should (approximately) become the average of $1$ and $1/3$, that is $2/3$. <>= call test (integrations_9, "integrations_9", & "handle sign change", & u, results) <>= public :: integrations_9 <>= subroutine integrations_9 (u) integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global type(string_t) :: wgt_expr_text type(ifile_t) :: ifile type(stream_t) :: stream type(parse_tree_t) :: parse_tree write (u, "(A)") "* Test output: integrations_9" write (u, "(A)") "* Purpose: integrate test process" write (u, "(A)") call syntax_model_file_init () call global%global_init () write (u, "(A)") "* Prepare a weight expression" write (u, "(A)") call syntax_pexpr_init () wgt_expr_text = "eval 2 * sgn (Pz) - 1 [s]" call ifile_append (ifile, wgt_expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (parse_tree, stream, .true.) global%pn%weight_expr => parse_tree%get_root_ptr () write (u, "(A)") "* Build and evaluate a test process" write (u, "(A)") libname = "integration_9" procname = "prc_config_a" call prepare_test_library (global, libname, 1) call compile_library (libname, global) call global%set_string (var_str ("$run_id"), & var_str ("integrations1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([1], [1000]) call reset_interaction_counter () call integrate_process (procname, global, local_stack=.true.) call global%write (u, vars = [ & var_str ("$method"), & var_str ("sqrts"), & var_str ("$integration_method"), & var_str ("$phs_method"), & var_str ("$run_id")]) call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: integrations_9" end subroutine integrations_9 @ %def integrations_9 @ \subsubsection{Integration history for VAMP integration with default phase space} This test is only run when event analysis can be done. <>= call test (integrations_history_1, "integrations_history_1", & "Test integration history files", & u, results) <>= public :: integrations_history_1 <>= subroutine integrations_history_1 (u) integer, intent(in) :: u type(string_t) :: libname, procname type(rt_data_t), target :: global type(string_t), dimension(0) :: no_vars integer :: iostat, u_his character(91) :: buffer type(string_t) :: his_file, ps_file, pdf_file logical :: exist, exist_ps, exist_pdf write (u, "(A)") "* Test output: integrations_history_1" write (u, "(A)") "* Purpose: test integration history files" write (u, "(A)") write (u, "(A)") "* Initialize process and parameters" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () call global%global_init () libname = "integrations_history_1_lib" procname = "integrations_history_1" call global%set_log (var_str ("?vis_history"), & .true., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?phs_s_mapping"),& .false., is_known = .true.) call prepare_test_library (global, libname, 1, [procname]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("wood"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .true., is_known = .true.) call global%set_real (var_str ("error_threshold"),& 5E-6_default, is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known=.true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([2, 2, 2], [1000, 1000, 1000], & adapt = [.true., .true., .false.], & adapt_code = [var_str ("wg"), var_str ("g"), var_str ("")]) write (u, "(A)") "* Integrate" write (u, "(A)") call reset_interaction_counter () call integrate_process (procname, global, local_stack=.true., & eff_reset = .true.) call global%pacify (efficiency_reset = .true., error_reset = .true.) call global%write (u, vars = no_vars, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Generated history files" write (u, "(A)") his_file = procname // ".r1.history.tex" ps_file = procname // ".r1.history.ps" pdf_file = procname // ".r1.history.pdf" inquire (file = char (his_file), exist = exist) if (exist) then u_his = free_unit () open (u_his, file = char (his_file), action = "read", status = "old") iostat = 0 do while (iostat == 0) read (u_his, "(A)", iostat = iostat) buffer if (iostat == 0) write (u, "(A)") trim (buffer) end do close (u_his) else write (u, "(A)") "[History LaTeX file is missing]" end if inquire (file = char (ps_file), exist = exist_ps) if (exist_ps) then write (u, "(A)") "[History Postscript file exists and is nonempty]" else write (u, "(A)") "[History Postscript file is missing/non-regular]" end if inquire (file = char (pdf_file), exist = exist_pdf) if (exist_pdf) then write (u, "(A)") "[History PDF file exists and is nonempty]" else write (u, "(A)") "[History PDF file is missing/non-regular]" end if write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_phs_forest_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: integrations_history_1" end subroutine integrations_history_1 @ %def integrations_history_1 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Event Streams} This module manages I/O from/to multiple concurrent event streams. Usually, there is at most one input stream, but several output streams. For the latter, we set up an array which can hold [[eio_t]] (event I/O) objects of different dynamic types simultaneously. One of them may be marked as an input channel. <<[[event_streams.f90]]>>= <> module event_streams <> use io_units use diagnostics use events use eio_data use eio_base use rt_data use dispatch_transforms, only: dispatch_eio <> <> <> contains <> end module event_streams @ %def event_streams @ \subsection{Event Stream Array} Each entry is an [[eio_t]] object. Since the type is dynamic, we need a wrapper: <>= type :: event_stream_entry_t class(eio_t), allocatable :: eio end type event_stream_entry_t @ %def event_stream_entry_t @ An array of event-stream entry objects. If one of the entries is an input channel, [[i_in]] is the corresponding index. <>= public :: event_stream_array_t <>= type :: event_stream_array_t type(event_stream_entry_t), dimension(:), allocatable :: entry integer :: i_in = 0 contains <> end type event_stream_array_t @ %def event_stream_array_t @ Output. <>= procedure :: write => event_stream_array_write <>= subroutine event_stream_array_write (object, unit) class(event_stream_array_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1x,A)") "Event stream array:" if (allocated (object%entry)) then select case (size (object%entry)) case (0) write (u, "(3x,A)") "[empty]" case default do i = 1, size (object%entry) if (i == object%i_in) write (u, "(1x,A)") "Input stream:" call object%entry(i)%eio%write (u) end do end select else write (u, "(3x,A)") "[undefined]" end if end subroutine event_stream_array_write @ %def event_stream_array_write @ Finalize all streams. <>= procedure :: final => event_stream_array_final <>= subroutine event_stream_array_final (es_array) class(event_stream_array_t), intent(inout) :: es_array integer :: i do i = 1, size (es_array%entry) call es_array%entry(i)%eio%final () end do end subroutine event_stream_array_final @ %def event_stream_array_final @ Initialization. We use a generic [[sample]] name, open event I/O objects for all provided stream types (using the [[dispatch_eio]] routine), and initialize for the given list of process pointers. If there is an [[input]] argument, this channel is initialized as an input channel and appended to the array. The [[input_data]] or, if not present, [[data]] may be modified. This happens if we open a stream for reading and get new information there. <>= procedure :: init => event_stream_array_init <>= subroutine event_stream_array_init & (es_array, sample, stream_fmt, global, & data, input, input_sample, input_data, allow_switch, & checkpoint, callback, & error) class(event_stream_array_t), intent(out) :: es_array type(string_t), intent(in) :: sample type(string_t), dimension(:), intent(in) :: stream_fmt type(rt_data_t), intent(in) :: global type(event_sample_data_t), intent(inout), optional :: data type(string_t), intent(in), optional :: input type(string_t), intent(in), optional :: input_sample type(event_sample_data_t), intent(inout), optional :: input_data logical, intent(in), optional :: allow_switch integer, intent(in), optional :: checkpoint integer, intent(in), optional :: callback logical, intent(out), optional :: error type(string_t) :: sample_in integer :: n, i, n_output, i_input, i_checkpoint, i_callback logical :: success, switch if (present (input_sample)) then sample_in = input_sample else sample_in = sample end if if (present (allow_switch)) then switch = allow_switch else switch = .true. end if if (present (error)) then error = .false. end if n = size (stream_fmt) n_output = n if (present (input)) then n = n + 1 i_input = n else i_input = 0 end if if (present (checkpoint)) then n = n + 1 i_checkpoint = n else i_checkpoint = 0 end if if (present (callback)) then n = n + 1 i_callback = n else i_callback = 0 end if allocate (es_array%entry (n)) if (i_checkpoint > 0) then call dispatch_eio & (es_array%entry(i_checkpoint)%eio, var_str ("checkpoint"), & global%var_list, global%fallback_model, & global%event_callback) call es_array%entry(i_checkpoint)%eio%init_out (sample, data) end if if (i_callback > 0) then call dispatch_eio & (es_array%entry(i_callback)%eio, var_str ("callback"), & global%var_list, global%fallback_model, & global%event_callback) call es_array%entry(i_callback)%eio%init_out (sample, data) end if if (i_input > 0) then call dispatch_eio (es_array%entry(i_input)%eio, input, & global%var_list, global%fallback_model, & global%event_callback) if (present (input_data)) then call es_array%entry(i_input)%eio%init_in & (sample_in, input_data, success) else call es_array%entry(i_input)%eio%init_in & (sample_in, data, success) end if if (success) then es_array%i_in = i_input else if (present (input_sample)) then if (present (error)) then error = .true. else call msg_fatal ("Events: & ¶meter mismatch in input, aborting") end if else call msg_message ("Events: & ¶meter mismatch, discarding old event set") call es_array%entry(i_input)%eio%final () if (switch) then call msg_message ("Events: generating new events") call es_array%entry(i_input)%eio%init_out (sample, data) end if end if end if do i = 1, n_output call dispatch_eio (es_array%entry(i)%eio, stream_fmt(i), & global%var_list, global%fallback_model, & global%event_callback) call es_array%entry(i)%eio%init_out (sample, data) end do end subroutine event_stream_array_init @ %def event_stream_array_init @ Switch the (only) input channel to an output channel, so further events are appended to the respective stream. <>= procedure :: switch_inout => event_stream_array_switch_inout <>= subroutine event_stream_array_switch_inout (es_array) class(event_stream_array_t), intent(inout) :: es_array integer :: n if (es_array%has_input ()) then n = es_array%i_in call es_array%entry(n)%eio%switch_inout () es_array%i_in = 0 else call msg_bug ("Reading events: switch_inout: no input stream selected") end if end subroutine event_stream_array_switch_inout @ %def event_stream_array_switch_inout @ Output an event (with given process number) to all output streams. If there is no output stream, do nothing. <>= procedure :: output => event_stream_array_output <>= subroutine event_stream_array_output (es_array, event, i_prc, & event_index, passed, pacify) class(event_stream_array_t), intent(inout) :: es_array type(event_t), intent(in), target :: event integer, intent(in) :: i_prc, event_index logical, intent(in), optional :: passed, pacify logical :: increased integer :: i do i = 1, size (es_array%entry) if (i /= es_array%i_in) then associate (eio => es_array%entry(i)%eio) if (eio%split) then if (eio%split_n_evt > 0 .and. event_index > 1) then if (mod (event_index, eio%split_n_evt) == 1) then call eio%split_out () end if else if (eio%split_n_kbytes > 0) then call eio%update_split_count (increased) if (increased) call eio%split_out () end if end if call eio%output (event, i_prc, reading = es_array%i_in /= 0, & passed = passed, & pacify = pacify) end associate end if end do end subroutine event_stream_array_output @ %def event_stream_array_output @ Input the [[i_prc]] index which selects the process for the current event. This is separated from reading the event, because it determines which event record to read. [[iostat]] may indicate an error or an EOF condition, as usual. <>= procedure :: input_i_prc => event_stream_array_input_i_prc <>= subroutine event_stream_array_input_i_prc (es_array, i_prc, iostat) class(event_stream_array_t), intent(inout) :: es_array integer, intent(out) :: i_prc integer, intent(out) :: iostat integer :: n if (es_array%has_input ()) then n = es_array%i_in call es_array%entry(n)%eio%input_i_prc (i_prc, iostat) else call msg_fatal ("Reading events: no input stream selected") end if end subroutine event_stream_array_input_i_prc @ %def event_stream_array_input_i_prc @ Input an event from the selected input stream. [[iostat]] may indicate an error or an EOF condition, as usual. <>= procedure :: input_event => event_stream_array_input_event <>= subroutine event_stream_array_input_event (es_array, event, iostat) class(event_stream_array_t), intent(inout) :: es_array type(event_t), intent(inout), target :: event integer, intent(out) :: iostat integer :: n if (es_array%has_input ()) then n = es_array%i_in call es_array%entry(n)%eio%input_event (event, iostat) else call msg_fatal ("Reading events: no input stream selected") end if end subroutine event_stream_array_input_event @ %def event_stream_array_input_event @ Skip an entry of eio\_t. Used to synchronize the event read-in for NLO events. <>= procedure :: skip_eio_entry => event_stream_array_skip_eio_entry <>= subroutine event_stream_array_skip_eio_entry (es_array, iostat) class(event_stream_array_t), intent(inout) :: es_array integer, intent(out) :: iostat integer :: n if (es_array%has_input ()) then n = es_array%i_in call es_array%entry(n)%eio%skip (iostat) else call msg_fatal ("Reading events: no input stream selected") end if end subroutine event_stream_array_skip_eio_entry @ %def event_stream_array_skip_eio_entry @ Return true if there is an input channel among the event streams. <>= procedure :: has_input => event_stream_array_has_input <>= function event_stream_array_has_input (es_array) result (flag) class(event_stream_array_t), intent(in) :: es_array logical :: flag flag = es_array%i_in /= 0 end function event_stream_array_has_input @ %def event_stream_array_has_input @ \subsection{Unit Tests} Test module, followed by the stand-alone unit-test procedures. <<[[event_streams_ut.f90]]>>= <> module event_streams_ut use unit_tests use event_streams_uti <> <> contains <> end module event_streams_ut @ <<[[event_streams_uti.f90]]>>= <> module event_streams_uti <> <> use model_data use eio_data use process, only: process_t use instances, only: process_instance_t use models use rt_data use events use event_streams <> <> contains <> end module event_streams_uti @ %def event_streams_uti @ API: driver for the unit tests below. <>= public :: event_streams_test <>= subroutine event_streams_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine event_streams_test @ %def event_streams_test @ \subsubsection{Empty event stream} This should set up an empty event output stream array, including initialization, output, and finalization (which are all no-ops). <>= call test (event_streams_1, "event_streams_1", & "empty event stream array", & u, results) <>= public :: event_streams_1 <>= subroutine event_streams_1 (u) integer, intent(in) :: u type(event_stream_array_t) :: es_array type(rt_data_t) :: global type(event_t) :: event type(string_t) :: sample type(string_t), dimension(0) :: empty_string_array write (u, "(A)") "* Test output: event_streams_1" write (u, "(A)") "* Purpose: handle empty event stream array" write (u, "(A)") sample = "event_streams_1" call es_array%init (sample, empty_string_array, global) call es_array%output (event, 42, 1) call es_array%write (u) call es_array%final () write (u, "(A)") write (u, "(A)") "* Test output end: event_streams_1" end subroutine event_streams_1 @ %def event_streams_1 @ \subsubsection{Nontrivial event stream} Here we generate a trivial event and choose [[raw]] output as an entry in the stream array. <>= call test (event_streams_2, "event_streams_2", & "nontrivial event stream array", & u, results) <>= public :: event_streams_2 <>= subroutine event_streams_2 (u) use processes_ut, only: prepare_test_process integer, intent(in) :: u type(event_stream_array_t) :: es_array type(rt_data_t) :: global type(model_data_t), target :: model type(event_t), allocatable, target :: event type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance type(string_t) :: sample type(string_t), dimension(0) :: empty_string_array integer :: i_prc, iostat write (u, "(A)") "* Test output: event_streams_2" write (u, "(A)") "* Purpose: handle empty event stream array" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call model%init_test () write (u, "(A)") "* Generate test process event" write (u, "(A)") allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model, & run_id = var_str ("run_test")) call process_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) call event%generate (1, [0.4_default, 0.4_default]) call event%set_index (42) call event%evaluate_expressions () call event%write (u) write (u, "(A)") write (u, "(A)") "* Allocate raw eio stream and write event to file" write (u, "(A)") sample = "event_streams_2" call es_array%init (sample, [var_str ("raw")], global) call es_array%output (event, 1, 1) call es_array%write (u) call es_array%final () write (u, "(A)") write (u, "(A)") "* Reallocate raw eio stream for reading" write (u, "(A)") sample = "foo" call es_array%init (sample, empty_string_array, global, & input = var_str ("raw"), input_sample = var_str ("event_streams_2")) call es_array%write (u) write (u, "(A)") write (u, "(A)") "* Reread event" write (u, "(A)") call es_array%input_i_prc (i_prc, iostat) write (u, "(1x,A,I0)") "i_prc = ", i_prc write (u, "(A)") call es_array%input_event (event, iostat) call es_array%final () call event%write (u) call global%final () call model%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: event_streams_2" end subroutine event_streams_2 @ %def event_streams_2 @ \subsubsection{Switch in/out} Here we generate an event file and test switching from writing to reading when the file is exhausted. <>= call test (event_streams_3, "event_streams_3", & "switch input/output", & u, results) <>= public :: event_streams_3 <>= subroutine event_streams_3 (u) use processes_ut, only: prepare_test_process integer, intent(in) :: u type(event_stream_array_t) :: es_array type(rt_data_t) :: global type(model_data_t), target :: model type(event_t), allocatable, target :: event type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance type(string_t) :: sample type(string_t), dimension(0) :: empty_string_array integer :: i_prc, iostat write (u, "(A)") "* Test output: event_streams_3" write (u, "(A)") "* Purpose: handle in/out switching" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call model%init_test () write (u, "(A)") "* Generate test process event" write (u, "(A)") allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model, & run_id = var_str ("run_test")) call process_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) call event%generate (1, [0.4_default, 0.4_default]) call event%increment_index () call event%evaluate_expressions () write (u, "(A)") "* Allocate raw eio stream and write event to file" write (u, "(A)") sample = "event_streams_3" call es_array%init (sample, [var_str ("raw")], global) call es_array%output (event, 1, 1) call es_array%write (u) call es_array%final () write (u, "(A)") write (u, "(A)") "* Reallocate raw eio stream for reading" write (u, "(A)") call es_array%init (sample, empty_string_array, global, & input = var_str ("raw")) call es_array%write (u) write (u, "(A)") write (u, "(A)") "* Reread event" write (u, "(A)") call es_array%input_i_prc (i_prc, iostat) call es_array%input_event (event, iostat) write (u, "(A)") "* Attempt to read another event (fail), then generate" write (u, "(A)") call es_array%input_i_prc (i_prc, iostat) if (iostat < 0) then call es_array%switch_inout () call event%generate (1, [0.3_default, 0.3_default]) call event%increment_index () call event%evaluate_expressions () call es_array%output (event, 1, 2) end if call es_array%write (u) call es_array%final () write (u, "(A)") call event%write (u) write (u, "(A)") write (u, "(A)") "* Reallocate raw eio stream for reading" write (u, "(A)") call es_array%init (sample, empty_string_array, global, & input = var_str ("raw")) call es_array%write (u) write (u, "(A)") write (u, "(A)") "* Reread two events and display 2nd event" write (u, "(A)") call es_array%input_i_prc (i_prc, iostat) call es_array%input_event (event, iostat) call es_array%input_i_prc (i_prc, iostat) call es_array%input_event (event, iostat) call es_array%final () call event%write (u) call global%final () call model%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: event_streams_3" end subroutine event_streams_3 @ %def event_streams_3 @ \subsubsection{Checksum} Here we generate an event file and repeat twice, once with identical parameters and once with modified parameters. <>= call test (event_streams_4, "event_streams_4", & "check MD5 sum", & u, results) <>= public :: event_streams_4 <>= subroutine event_streams_4 (u) integer, intent(in) :: u type(event_stream_array_t) :: es_array type(rt_data_t) :: global type(process_t), allocatable, target :: process type(string_t) :: sample type(string_t), dimension(0) :: empty_string_array type(event_sample_data_t) :: data write (u, "(A)") "* Test output: event_streams_4" write (u, "(A)") "* Purpose: handle in/out switching" write (u, "(A)") write (u, "(A)") "* Generate test process event" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call global%set_log (var_str ("?check_event_file"), & .true., is_known = .true.) allocate (process) write (u, "(A)") "* Allocate raw eio stream for writing" write (u, "(A)") sample = "event_streams_4" data%md5sum_cfg = "1234567890abcdef1234567890abcdef" call es_array%init (sample, [var_str ("raw")], global, data) call es_array%write (u) call es_array%final () write (u, "(A)") write (u, "(A)") "* Reallocate raw eio stream for reading" write (u, "(A)") call es_array%init (sample, empty_string_array, global, & data, input = var_str ("raw")) call es_array%write (u) call es_array%final () write (u, "(A)") write (u, "(A)") "* Reallocate modified raw eio stream for reading (fail)" write (u, "(A)") data%md5sum_cfg = "1234567890______1234567890______" call es_array%init (sample, empty_string_array, global, & data, input = var_str ("raw")) call es_array%write (u) call es_array%final () write (u, "(A)") write (u, "(A)") "* Repeat ignoring checksum" write (u, "(A)") call global%set_log (var_str ("?check_event_file"), & .false., is_known = .true.) call es_array%init (sample, empty_string_array, global, & data, input = var_str ("raw")) call es_array%write (u) call es_array%final () call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: event_streams_4" end subroutine event_streams_4 @ %def event_streams_4 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Restricted Subprocesses} This module provides an automatic means to construct restricted subprocesses of a current process object. A restricted subprocess has the same initial and final state as the current process, but a restricted set of Feynman graphs. The actual application extracts the set of resonance histories that apply to the process and uses this to construct subprocesses that are restricted to one of those histories, respectively. The resonance histories are derived from the phase-space setup. This implies that the method is tied to the OMega matrix element generator and to the wood phase space method. The processes are collected in a new process library that is generated on-the-fly. The [[resonant_subprocess_t]] object is intended as a component of the event record, which manages all operations regarding resonance handling. The run-time calculations are delegated to an event transform ([[evt_resonance_t]]), as a part of the event transform chain. The transform selects one (or none) of the resonance histories, given the momentum configuration, computes matrix elements and inserts resonances into the particle set. <<[[restricted_subprocesses.f90]]>>= <> module restricted_subprocesses <> <> use diagnostics, only: msg_message, msg_fatal, msg_bug use diagnostics, only: signal_is_pending use io_units, only: given_output_unit use format_defs, only: FMT_14, FMT_19 use string_utils, only: str use lorentz, only: vector4_t use particle_specifiers, only: prt_spec_t use particles, only: particle_set_t use resonances, only: resonance_history_t, resonance_history_set_t use variables, only: var_list_t use models, only: model_t use process_libraries, only: process_component_def_t use process_libraries, only: process_library_t use process_libraries, only: STAT_ACTIVE use prclib_stacks, only: prclib_entry_t use event_transforms, only: evt_t use resonance_insertion, only: evt_resonance_t use rt_data, only: rt_data_t use compilations, only: compile_library use process_configurations, only: process_configuration_t use process, only: process_t, process_ptr_t use instances, only: process_instance_t, process_instance_ptr_t use integrations, only: integrate_process <> <> <> <> <> contains <> end module restricted_subprocesses @ %def restricted_subprocesses @ \subsection{Process configuration} We extend the [[process_configuration_t]] by another method for initialization that takes into account a resonance history. <>= public :: restricted_process_configuration_t <>= type, extends (process_configuration_t) :: restricted_process_configuration_t private contains <> end type restricted_process_configuration_t @ %def restricted_process_configuration_t @ Resonance history as an argument. We use it to override the [[restrictions]] setting in a local variable list. Since we can construct the restricted process only by using OMega, we enforce it as the ME method. Other settings are taken from the variable list. The model will most likely be set, but we insert a safeguard just in case. Also, the resonant subprocess should not itself spawn resonant subprocesses, so we unset [[?resonance_history]]. We have to create a local copy of the model here, via pointer allocation. The reason is that the model as stored (via pointer) in the base type will be finalized and deallocated. The current implementation will generate a LO process, the optional [[nlo_process]] is unset. (It is not obvious whether the construction makes sense beyond LO.) <>= procedure :: init_resonant_process <>= subroutine init_resonant_process & (prc_config, prc_name, prt_in, prt_out, res_history, model, var_list) class(restricted_process_configuration_t), intent(out) :: prc_config type(string_t), intent(in) :: prc_name type(prt_spec_t), dimension(:), intent(in) :: prt_in type(prt_spec_t), dimension(:), intent(in) :: prt_out type(resonance_history_t), intent(in) :: res_history type(model_t), intent(in), target :: model type(var_list_t), intent(in), target :: var_list type(model_t), pointer :: local_model type(var_list_t) :: local_var_list allocate (local_model) call local_model%init_instance (model) call local_var_list%link (var_list) call local_var_list%append_string (var_str ("$model_name"), & sval = local_model%get_name (), & intrinsic=.true.) call local_var_list%append_string (var_str ("$method"), & sval = var_str ("omega"), & intrinsic=.true.) call local_var_list%append_string (var_str ("$restrictions"), & sval = res_history%as_omega_string (size (prt_in)), & intrinsic = .true.) call local_var_list%append_log (var_str ("?resonance_history"), & lval = .false., & intrinsic = .true.) call prc_config%init (prc_name, size (prt_in), 1, & local_model, local_var_list) call prc_config%setup_component (1, & prt_in, prt_out, & local_model, local_var_list) end subroutine init_resonant_process @ %def init_resonant_process @ \subsection{Resonant-subprocess set manager} This data type enables generation of a library of resonant subprocesses for a given master process, and it allows for convenient access. The matrix elements from the subprocesses can be used as channel weights to activate a selector, which then returns a preferred channel via some random number generator. <>= public :: resonant_subprocess_set_t <>= type :: resonant_subprocess_set_t private integer, dimension(:), allocatable :: n_history type(resonance_history_set_t), dimension(:), allocatable :: res_history_set logical :: lib_active = .false. type(string_t) :: libname type(string_t), dimension(:), allocatable :: proc_id type(process_ptr_t), dimension(:), allocatable :: subprocess type(process_instance_ptr_t), dimension(:), allocatable :: instance logical :: filled = .false. type(evt_resonance_t), pointer :: evt => null () contains <> end type resonant_subprocess_set_t @ %def resonant_subprocess_set_t @ Output <>= procedure :: write => resonant_subprocess_set_write <>= subroutine resonant_subprocess_set_write (prc_set, unit, testflag) class(resonant_subprocess_set_t), intent(in) :: prc_set integer, intent(in), optional :: unit logical, intent(in), optional :: testflag logical :: truncate integer :: u, i u = given_output_unit (unit) truncate = .false.; if (present (testflag)) truncate = testflag write (u, "(1x,A)") "Resonant subprocess set:" if (allocated (prc_set%n_history)) then if (any (prc_set%n_history > 0)) then do i = 1, size (prc_set%n_history) if (prc_set%n_history(i) > 0) then write (u, "(1x,A,I0)") "Component #", i call prc_set%res_history_set(i)%write (u, indent=1) end if end do if (prc_set%lib_active) then write (u, "(3x,A,A,A)") "Process library = '", & char (prc_set%libname), "'" else write (u, "(3x,A)") "Process library: [inactive]" end if if (associated (prc_set%evt)) then if (truncate) then write (u, "(3x,A,1x," // FMT_14 // ")") & "Process sqme =", prc_set%get_master_sqme () else write (u, "(3x,A,1x," // FMT_19 // ")") & "Process sqme =", prc_set%get_master_sqme () end if end if if (associated (prc_set%evt)) then write (u, "(3x,A)") "Event transform: associated" write (u, "(2x)", advance="no") call prc_set%evt%write_selector (u, testflag) else write (u, "(3x,A)") "Event transform: not associated" end if else write (u, "(2x,A)") "[empty]" end if else write (u, "(3x,A)") "[not allocated]" end if end subroutine resonant_subprocess_set_write @ %def resonant_subprocess_set_write @ \subsection{Resonance history set} Initialize subprocess set with an array of pre-created resonance history sets. Safeguard: if there are no resonances in the input, initialize the local set as empty, but complete. <>= procedure :: init => resonant_subprocess_set_init procedure :: fill_resonances => resonant_subprocess_set_fill_resonances <>= subroutine resonant_subprocess_set_init (prc_set, n_component) class(resonant_subprocess_set_t), intent(out) :: prc_set integer, intent(in) :: n_component allocate (prc_set%res_history_set (n_component)) allocate (prc_set%n_history (n_component), source = 0) end subroutine resonant_subprocess_set_init subroutine resonant_subprocess_set_fill_resonances (prc_set, & res_history_set, i_component) class(resonant_subprocess_set_t), intent(inout) :: prc_set type(resonance_history_set_t), intent(in) :: res_history_set integer, intent(in) :: i_component prc_set%n_history(i_component) = res_history_set%get_n_history () if (prc_set%n_history(i_component) > 0) then prc_set%res_history_set(i_component) = res_history_set else call prc_set%res_history_set(i_component)%init (initial_size = 0) call prc_set%res_history_set(i_component)%freeze () end if end subroutine resonant_subprocess_set_fill_resonances @ %def resonant_subprocess_set_init @ %def resonant_subprocess_set_fill_resonances @ Return the resonance history set. <>= procedure :: get_resonance_history_set & => resonant_subprocess_set_get_resonance_history_set <>= function resonant_subprocess_set_get_resonance_history_set (prc_set) & result (res_history_set) class(resonant_subprocess_set_t), intent(in) :: prc_set type(resonance_history_set_t), dimension(:), allocatable :: res_history_set res_history_set = prc_set%res_history_set end function resonant_subprocess_set_get_resonance_history_set @ %def resonant_subprocess_set_get_resonance_history_set @ \subsection{Library for the resonance history set} The recommended library name: append [[_R]] to the process name. <>= public :: get_libname_res <>= elemental function get_libname_res (proc_id) result (libname) type(string_t), intent(in) :: proc_id type(string_t) :: libname libname = proc_id // "_R" end function get_libname_res @ %def get_libname_res @ Here we scan the global process library whether any processes require resonant subprocesses to be constructed. If yes, create process objects with phase space and construct the process libraries as usual. Then append the library names to the array. The temporary integration objects should carry the [[phs_only]] flag. We set this in the local environment. Once a process object with resonance histories (derived from phase space) has been created, we extract the resonance histories and use them, together with the process definition, to create the new library. Finally, compile the library. <>= public :: spawn_resonant_subprocess_libraries <>= subroutine spawn_resonant_subprocess_libraries & (libname, local, global, libname_res) type(string_t), intent(in) :: libname type(rt_data_t), intent(inout), target :: local type(rt_data_t), intent(inout), target :: global type(string_t), dimension(:), allocatable, intent(inout) :: libname_res type(process_library_t), pointer :: lib type(string_t), dimension(:), allocatable :: process_id_res type(process_t), pointer :: process type(resonance_history_set_t) :: res_history_set type(process_component_def_t), pointer :: process_component_def logical :: phs_only_saved, exist integer :: i_proc, i_component lib => global%prclib_stack%get_library_ptr (libname) call lib%get_process_id_req_resonant (process_id_res) if (size (process_id_res) > 0) then call msg_message ("Creating resonant-subprocess libraries & &for library '" // char (libname) // "'") libname_res = get_libname_res (process_id_res) phs_only_saved = local%var_list%get_lval (var_str ("?phs_only")) call local%var_list%set_log & (var_str ("?phs_only"), .true., is_known=.true.) do i_proc = 1, size (process_id_res) associate (proc_id => process_id_res (i_proc)) call msg_message ("Process '" // char (proc_id) // "': & &constructing phase space for resonance structure") call integrate_process (proc_id, local, global) process => global%process_stack%get_process_ptr (proc_id) call create_library (libname_res(i_proc), global, exist) if (.not. exist) then do i_component = 1, process%get_n_components () call process%extract_resonance_history_set & (res_history_set, i_component = i_component) process_component_def & => process%get_component_def_ptr (i_component) call add_to_library (libname_res(i_proc), & res_history_set, & process_component_def%get_prt_spec_in (), & process_component_def%get_prt_spec_out (), & global) end do call msg_message ("Process library '" & // char (libname_res(i_proc)) & // "': created") end if call global%update_prclib (lib) end associate end do call local%var_list%set_log & (var_str ("?phs_only"), phs_only_saved, is_known=.true.) end if end subroutine spawn_resonant_subprocess_libraries @ %def spawn_resonant_subprocess_libraries @ This is another version of the library constructor, bound to a restricted-subprocess set object. Create the appropriate process library, add processes, and close the library. <>= procedure :: create_library => resonant_subprocess_set_create_library procedure :: add_to_library => resonant_subprocess_set_add_to_library procedure :: freeze_library => resonant_subprocess_set_freeze_library <>= subroutine resonant_subprocess_set_create_library (prc_set, & libname, global, exist) class(resonant_subprocess_set_t), intent(inout) :: prc_set type(string_t), intent(in) :: libname type(rt_data_t), intent(inout), target :: global logical, intent(out) :: exist prc_set%libname = libname call create_library (prc_set%libname, global, exist) end subroutine resonant_subprocess_set_create_library subroutine resonant_subprocess_set_add_to_library (prc_set, & i_component, prt_in, prt_out, global) class(resonant_subprocess_set_t), intent(inout) :: prc_set integer, intent(in) :: i_component type(prt_spec_t), dimension(:), intent(in) :: prt_in type(prt_spec_t), dimension(:), intent(in) :: prt_out type(rt_data_t), intent(inout), target :: global call add_to_library (prc_set%libname, & prc_set%res_history_set(i_component), & prt_in, prt_out, global) end subroutine resonant_subprocess_set_add_to_library subroutine resonant_subprocess_set_freeze_library (prc_set, global) class(resonant_subprocess_set_t), intent(inout) :: prc_set type(rt_data_t), intent(inout), target :: global type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib lib => global%prclib_stack%get_library_ptr (prc_set%libname) call lib%get_process_id_list (prc_set%proc_id) prc_set%lib_active = .true. end subroutine resonant_subprocess_set_freeze_library @ %def resonant_subprocess_set_create_library @ %def resonant_subprocess_set_add_to_library @ %def resonant_subprocess_set_freeze_library @ The common parts of the procedures above: (i) create a new process library or recover it, (ii) for each history, create a process configuration and record it. <>= subroutine create_library (libname, global, exist) type(string_t), intent(in) :: libname type(rt_data_t), intent(inout), target :: global logical, intent(out) :: exist type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib type(resonance_history_t) :: res_history type(string_t), dimension(:), allocatable :: proc_id type(restricted_process_configuration_t) :: prc_config integer :: i lib => global%prclib_stack%get_library_ptr (libname) exist = associated (lib) if (.not. exist) then call msg_message ("Creating library for resonant subprocesses '" & // char (libname) // "'") allocate (lib_entry) call lib_entry%init (libname) lib => lib_entry%process_library_t call global%add_prclib (lib_entry) else call msg_message ("Using library for resonant subprocesses '" & // char (libname) // "'") call global%update_prclib (lib) end if end subroutine create_library subroutine add_to_library (libname, res_history_set, prt_in, prt_out, global) type(string_t), intent(in) :: libname type(resonance_history_set_t), intent(in) :: res_history_set type(prt_spec_t), dimension(:), intent(in) :: prt_in type(prt_spec_t), dimension(:), intent(in) :: prt_out type(rt_data_t), intent(inout), target :: global type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib type(resonance_history_t) :: res_history type(string_t), dimension(:), allocatable :: proc_id type(restricted_process_configuration_t) :: prc_config integer :: n0, i lib => global%prclib_stack%get_library_ptr (libname) if (associated (lib)) then n0 = lib%get_n_processes () allocate (proc_id (res_history_set%get_n_history ())) do i = 1, size (proc_id) proc_id(i) = libname // str (n0 + i) res_history = res_history_set%get_history(i) call prc_config%init_resonant_process (proc_id(i), & prt_in, prt_out, & res_history, & global%model, global%var_list) call msg_message ("Resonant subprocess #" & // char (str(n0+i)) // ": " & // char (res_history%as_omega_string (size (prt_in)))) call prc_config%record (global) if (signal_is_pending ()) return end do else call msg_bug ("Adding subprocesses: library '" & // char (libname) // "' not found") end if end subroutine add_to_library @ %def create_library @ %def add_to_library @ Compile the generated library, required settings taken from the [[global]] data set. <>= procedure :: compile_library => resonant_subprocess_set_compile_library <>= subroutine resonant_subprocess_set_compile_library (prc_set, global) class(resonant_subprocess_set_t), intent(in) :: prc_set type(rt_data_t), intent(inout), target :: global type(process_library_t), pointer :: lib lib => global%prclib_stack%get_library_ptr (prc_set%libname) if (lib%get_status () < STAT_ACTIVE) then call compile_library (prc_set%libname, global) end if end subroutine resonant_subprocess_set_compile_library @ %def resonant_subprocess_set_compile_library @ Check if the library has been created / the process has been evaluated. <>= procedure :: is_active => resonant_subprocess_set_is_active <>= function resonant_subprocess_set_is_active (prc_set) result (flag) class(resonant_subprocess_set_t), intent(in) :: prc_set logical :: flag flag = prc_set%lib_active end function resonant_subprocess_set_is_active @ %def resonant_subprocess_set_is_active @ Return number of generated process objects, library, and process IDs. <>= procedure :: get_n_process => resonant_subprocess_set_get_n_process procedure :: get_libname => resonant_subprocess_set_get_libname procedure :: get_proc_id => resonant_subprocess_set_get_proc_id <>= function resonant_subprocess_set_get_n_process (prc_set) result (n) class(resonant_subprocess_set_t), intent(in) :: prc_set integer :: n if (prc_set%lib_active) then n = size (prc_set%proc_id) else n = 0 end if end function resonant_subprocess_set_get_n_process function resonant_subprocess_set_get_libname (prc_set) result (libname) class(resonant_subprocess_set_t), intent(in) :: prc_set type(string_t) :: libname if (prc_set%lib_active) then libname = prc_set%libname else libname = "" end if end function resonant_subprocess_set_get_libname function resonant_subprocess_set_get_proc_id (prc_set, i) result (proc_id) class(resonant_subprocess_set_t), intent(in) :: prc_set integer, intent(in) :: i type(string_t) :: proc_id if (allocated (prc_set%proc_id)) then proc_id = prc_set%proc_id(i) else proc_id = "" end if end function resonant_subprocess_set_get_proc_id @ %def resonant_subprocess_set_get_n_process @ %def resonant_subprocess_set_get_libname @ %def resonant_subprocess_set_get_proc_id @ \subsection{Process objects and instances} Prepare process objects for all entries in the resonant-subprocesses library. The process objects are appended to the global process stack. A local environment can be used where we place temporary variable settings that affect process-object generation. We initialize the processes, such that we can evaluate matrix elements, but we do not need to integrate them. The internal procedure [[prepare_process]] is an abridged version of the procedure with this name in the [[simulations]] module. <>= procedure :: prepare_process_objects & => resonant_subprocess_set_prepare_process_objects <>= subroutine resonant_subprocess_set_prepare_process_objects & (prc_set, local, global) class(resonant_subprocess_set_t), intent(inout) :: prc_set type(rt_data_t), intent(inout), target :: local type(rt_data_t), intent(inout), optional, target :: global type(rt_data_t), pointer :: current type(process_library_t), pointer :: lib type(string_t) :: proc_id, libname_cur, libname_res integer :: i, n if (.not. prc_set%is_active ()) return if (present (global)) then current => global else current => local end if libname_cur = current%prclib%get_name () libname_res = prc_set%get_libname () lib => current%prclib_stack%get_library_ptr (libname_res) if (associated (lib)) call current%update_prclib (lib) call local%set_string (var_str ("$phs_method"), & var_str ("none"), is_known = .true.) call local%set_string (var_str ("$integration_method"), & var_str ("none"), is_known = .true.) n = prc_set%get_n_process () allocate (prc_set%subprocess (n)) do i = 1, n proc_id = prc_set%get_proc_id (i) call prepare_process (prc_set%subprocess(i)%p, proc_id) if (signal_is_pending ()) return end do lib => current%prclib_stack%get_library_ptr (libname_cur) if (associated (lib)) call current%update_prclib (lib) contains subroutine prepare_process (process, process_id) type(process_t), pointer, intent(out) :: process type(string_t), intent(in) :: process_id call msg_message ("Simulate: initializing resonant subprocess '" & // char (process_id) // "'") if (present (global)) then call integrate_process (process_id, local, global, & init_only = .true.) else call integrate_process (process_id, local, local_stack = .true., & init_only = .true.) end if process => current%process_stack%get_process_ptr (process_id) if (.not. associated (process)) then call msg_fatal ("Simulate: resonant subprocess '" & // char (process_id) // "' could not be initialized: aborting") end if end subroutine prepare_process end subroutine resonant_subprocess_set_prepare_process_objects @ %def resonant_subprocess_set_prepare_process_objects @ Workspace for the resonant subprocesses. <>= procedure :: prepare_process_instances & => resonant_subprocess_set_prepare_process_instances <>= subroutine resonant_subprocess_set_prepare_process_instances (prc_set, global) class(resonant_subprocess_set_t), intent(inout) :: prc_set type(rt_data_t), intent(in), target :: global integer :: i, n if (.not. prc_set%is_active ()) return n = size (prc_set%subprocess) allocate (prc_set%instance (n)) do i = 1, n allocate (prc_set%instance(i)%p) call prc_set%instance(i)%p%init (prc_set%subprocess(i)%p) call prc_set%instance(i)%p%setup_event_data (global%model) end do end subroutine resonant_subprocess_set_prepare_process_instances @ %def resonant_subprocess_set_prepare_process_instances @ \subsection{Event transform connection} The idea is that the resonance-insertion event transform has been allocated somewhere (namely, in the standard event-transform chain), but we maintain a link such that we can inject matrix-element results event by event. The event transform holds a selector, to choose one of the resonance histories (or none), and it manages resonance insertion for the particle set. The data that the event transform requires can be provided here. The resonance history set has already been assigned with the [[dispatch]] initializer. Here, we supply the set of subprocess instances that we have generated (see above). The master-process instance is set when we [[connect]] the transform by the standard method. <>= procedure :: connect_transform => & resonant_subprocess_set_connect_transform <>= subroutine resonant_subprocess_set_connect_transform (prc_set, evt) class(resonant_subprocess_set_t), intent(inout) :: prc_set class(evt_t), intent(in), target :: evt select type (evt) type is (evt_resonance_t) prc_set%evt => evt call prc_set%evt%set_subprocess_instances (prc_set%instance) class default call msg_bug ("Resonant subprocess set: event transform has wrong type") end select end subroutine resonant_subprocess_set_connect_transform @ %def resonant_subprocess_set_connect_transform @ Set the on-shell limit value in the connected transform. <>= procedure :: set_on_shell_limit => resonant_subprocess_set_on_shell_limit <>= subroutine resonant_subprocess_set_on_shell_limit (prc_set, on_shell_limit) class(resonant_subprocess_set_t), intent(inout) :: prc_set real(default), intent(in) :: on_shell_limit call prc_set%evt%set_on_shell_limit (on_shell_limit) end subroutine resonant_subprocess_set_on_shell_limit @ %def resonant_subprocess_set_on_shell_limit @ Set the Gaussian turnoff parameter in the connected transform. <>= procedure :: set_on_shell_turnoff => resonant_subprocess_set_on_shell_turnoff <>= subroutine resonant_subprocess_set_on_shell_turnoff & (prc_set, on_shell_turnoff) class(resonant_subprocess_set_t), intent(inout) :: prc_set real(default), intent(in) :: on_shell_turnoff call prc_set%evt%set_on_shell_turnoff (on_shell_turnoff) end subroutine resonant_subprocess_set_on_shell_turnoff @ %def resonant_subprocess_set_on_shell_turnoff @ Reweight (suppress) the background contribution probability, for the kinematics where a resonance history is active. <>= procedure :: set_background_factor & => resonant_subprocess_set_background_factor <>= subroutine resonant_subprocess_set_background_factor & (prc_set, background_factor) class(resonant_subprocess_set_t), intent(inout) :: prc_set real(default), intent(in) :: background_factor call prc_set%evt%set_background_factor (background_factor) end subroutine resonant_subprocess_set_background_factor @ %def resonant_subprocess_set_background_factor @ \subsection{Wrappers for runtime calculations} All runtime calculations are delegated to the event transform. The following procedures are essentially redundant wrappers. We retain them for a unit test below. Debugging aid: <>= procedure :: dump_instances => resonant_subprocess_set_dump_instances <>= subroutine resonant_subprocess_set_dump_instances (prc_set, unit, testflag) class(resonant_subprocess_set_t), intent(inout) :: prc_set integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: i, n, u u = given_output_unit (unit) write (u, "(A)") "*** Process instances of resonant subprocesses" write (u, *) n = size (prc_set%subprocess) do i = 1, n associate (instance => prc_set%instance(i)%p) call instance%write (u, testflag) write (u, *) write (u, *) end associate end do end subroutine resonant_subprocess_set_dump_instances @ %def resonant_subprocess_set_dump_instances @ Inject the current kinematics configuration, reading from the previous event transform or from the process instance. <>= procedure :: fill_momenta => resonant_subprocess_set_fill_momenta <>= subroutine resonant_subprocess_set_fill_momenta (prc_set) class(resonant_subprocess_set_t), intent(inout) :: prc_set integer :: i, n call prc_set%evt%fill_momenta () end subroutine resonant_subprocess_set_fill_momenta @ %def resonant_subprocess_set_fill_momenta @ Determine the indices of the resonance histories that can be considered on-shell for the current kinematics. <>= procedure :: determine_on_shell_histories & => resonant_subprocess_set_determine_on_shell_histories <>= subroutine resonant_subprocess_set_determine_on_shell_histories & (prc_set, i_component, index_array) class(resonant_subprocess_set_t), intent(in) :: prc_set integer, intent(in) :: i_component integer, dimension(:), allocatable, intent(out) :: index_array call prc_set%evt%determine_on_shell_histories (index_array) end subroutine resonant_subprocess_set_determine_on_shell_histories @ %def resonant_subprocess_set_determine_on_shell_histories @ Evaluate selected subprocesses. (In actual operation, the ones that have been tagged as on-shell.) <>= procedure :: evaluate_subprocess & => resonant_subprocess_set_evaluate_subprocess <>= subroutine resonant_subprocess_set_evaluate_subprocess (prc_set, index_array) class(resonant_subprocess_set_t), intent(inout) :: prc_set integer, dimension(:), intent(in) :: index_array call prc_set%evt%evaluate_subprocess (index_array) end subroutine resonant_subprocess_set_evaluate_subprocess @ %def resonant_subprocess_set_evaluate_subprocess @ Extract the matrix elements of the master process / the resonant subprocesses. After the previous routine has been executed, they should be available and stored in the corresponding process instances. <>= procedure :: get_master_sqme & => resonant_subprocess_set_get_master_sqme procedure :: get_subprocess_sqme & => resonant_subprocess_set_get_subprocess_sqme <>= function resonant_subprocess_set_get_master_sqme (prc_set) result (sqme) class(resonant_subprocess_set_t), intent(in) :: prc_set real(default) :: sqme sqme = prc_set%evt%get_master_sqme () end function resonant_subprocess_set_get_master_sqme subroutine resonant_subprocess_set_get_subprocess_sqme (prc_set, sqme) class(resonant_subprocess_set_t), intent(in) :: prc_set real(default), dimension(:), intent(inout) :: sqme integer :: i call prc_set%evt%get_subprocess_sqme (sqme) end subroutine resonant_subprocess_set_get_subprocess_sqme @ %def resonant_subprocess_set_get_master_sqme @ %def resonant_subprocess_set_get_subprocess_sqme @ We use the calculations of resonant matrix elements to determine probabilities for all resonance configurations. <>= procedure :: compute_probabilities & => resonant_subprocess_set_compute_probabilities <>= subroutine resonant_subprocess_set_compute_probabilities (prc_set, prob_array) class(resonant_subprocess_set_t), intent(inout) :: prc_set real(default), dimension(:), allocatable, intent(out) :: prob_array integer, dimension(:), allocatable :: index_array real(default) :: sqme, sqme_sum, sqme_bg real(default), dimension(:), allocatable :: sqme_res integer :: n n = size (prc_set%subprocess) allocate (prob_array (0:n), source = 0._default) call prc_set%evt%compute_probabilities () call prc_set%evt%get_selector_weights (prob_array) end subroutine resonant_subprocess_set_compute_probabilities @ %def resonant_subprocess_set_compute_probabilities @ \subsection{Unit tests} Test module, followed by the stand-alone unit-test procedures. <<[[restricted_subprocesses_ut.f90]]>>= <> module restricted_subprocesses_ut use unit_tests use restricted_subprocesses_uti <> <> contains <> end module restricted_subprocesses_ut @ %def restricted_subprocesses_ut @ <<[[restricted_subprocesses_uti.f90]]>>= <> module restricted_subprocesses_uti <> <> use io_units, only: free_unit use format_defs, only: FMT_10, FMT_12 use lorentz, only: vector4_t, vector3_moving, vector4_moving use particle_specifiers, only: new_prt_spec use process_libraries, only: process_library_t use resonances, only: resonance_info_t use resonances, only: resonance_history_t use resonances, only: resonance_history_set_t use state_matrices, only: FM_IGNORE_HELICITY use particles, only: particle_set_t use model_data, only: model_data_t use models, only: syntax_model_file_init, syntax_model_file_final use models, only: model_t use rng_base_ut, only: rng_test_factory_t use mci_base, only: mci_t use mci_none, only: mci_none_t use phs_base, only: phs_config_t use phs_forests, only: syntax_phs_forest_init, syntax_phs_forest_final use phs_wood, only: phs_wood_config_t use process_libraries, only: process_def_entry_t use process_libraries, only: process_component_def_t use prclib_stacks, only: prclib_entry_t use prc_core_def, only: prc_core_def_t use prc_omega, only: omega_def_t use process, only: process_t use instances, only: process_instance_t use process_stacks, only: process_entry_t use event_transforms, only: evt_trivial_t use resonance_insertion, only: evt_resonance_t use integrations, only: integrate_process use rt_data, only: rt_data_t use restricted_subprocesses <> <> <> <> contains <> <> end module restricted_subprocesses_uti @ %def restricted_subprocesses_uti @ API: driver for the unit tests below. <>= public :: restricted_subprocesses_test <>= subroutine restricted_subprocesses_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine restricted_subprocesses_test @ %def restricted_subprocesses_test @ \subsubsection{subprocess configuration} Initialize a [[restricted_subprocess_configuration_t]] object which represents a given process with a defined resonance history. <>= call test (restricted_subprocesses_1, "restricted_subprocesses_1", & "single subprocess", & u, results) <>= public :: restricted_subprocesses_1 <>= subroutine restricted_subprocesses_1 (u) integer, intent(in) :: u type(rt_data_t) :: global type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(string_t) :: prc_name type(string_t), dimension(2) :: prt_in type(string_t), dimension(3) :: prt_out type(restricted_process_configuration_t) :: prc_config write (u, "(A)") "* Test output: restricted_subprocesses_1" write (u, "(A)") "* Purpose: create subprocess list from resonances" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%select_model (var_str ("SM")) write (u, "(A)") "* Create resonance history" write (u, "(A)") call res_info%init (3, -24, global%model, 5) call res_history%add_resonance (res_info) call res_history%write (u) write (u, "(A)") write (u, "(A)") "* Create process configuration" write (u, "(A)") prc_name = "restricted_subprocesses_1_p" prt_in(1) = "e-" prt_in(2) = "e+" prt_out(1) = "d" prt_out(2) = "u" prt_out(3) = "W+" call prc_config%init_resonant_process (prc_name, & new_prt_spec (prt_in), new_prt_spec (prt_out), & res_history, global%model, global%var_list) call prc_config%write (u) write (u, *) write (u, "(A)") "* Cleanup" call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: restricted_subprocesses_1" end subroutine restricted_subprocesses_1 @ %def restricted_subprocesses_1 @ \subsubsection{Subprocess library configuration} Create a process library that represents restricted subprocesses for a given set of resonance histories <>= call test (restricted_subprocesses_2, "restricted_subprocesses_2", & "subprocess library", & u, results) <>= public :: restricted_subprocesses_2 <>= subroutine restricted_subprocesses_2 (u) integer, intent(in) :: u type(rt_data_t), target :: global type(resonance_info_t) :: res_info type(resonance_history_t), dimension(2) :: res_history type(resonance_history_set_t) :: res_history_set type(string_t) :: libname type(string_t), dimension(2) :: prt_in type(string_t), dimension(3) :: prt_out type(resonant_subprocess_set_t) :: prc_set type(process_library_t), pointer :: lib logical :: exist write (u, "(A)") "* Test output: restricted_subprocesses_2" write (u, "(A)") "* Purpose: create subprocess library from resonances" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%select_model (var_str ("SM")) write (u, "(A)") "* Create resonance histories" write (u, "(A)") call res_info%init (3, -24, global%model, 5) call res_history(1)%add_resonance (res_info) call res_history(1)%write (u) call res_info%init (7, 23, global%model, 5) call res_history(2)%add_resonance (res_info) call res_history(2)%write (u) call res_history_set%init () call res_history_set%enter (res_history(1)) call res_history_set%enter (res_history(2)) call res_history_set%freeze () write (u, "(A)") write (u, "(A)") "* Empty restricted subprocess set" write (u, "(A)") write (u, "(A,1x,L1)") "active =", prc_set%is_active () write (u, "(A)") call prc_set%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Fill restricted subprocess set" write (u, "(A)") libname = "restricted_subprocesses_2_p_R" prt_in(1) = "e-" prt_in(2) = "e+" prt_out(1) = "d" prt_out(2) = "u" prt_out(3) = "W+" call prc_set%init (1) call prc_set%fill_resonances (res_history_set, 1) call prc_set%create_library (libname, global, exist) if (.not. exist) then call prc_set%add_to_library (1, & new_prt_spec (prt_in), new_prt_spec (prt_out), & global) end if call prc_set%freeze_library (global) write (u, "(A,1x,L1)") "active =", prc_set%is_active () write (u, "(A)") call prc_set%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Queries" write (u, "(A)") write (u, "(A,1x,I0)") "n_process =", prc_set%get_n_process () write (u, "(A)") write (u, "(A,A,A)") "libname = '", char (prc_set%get_libname ()), "'" write (u, "(A)") write (u, "(A,A,A)") "proc_id(1) = '", char (prc_set%get_proc_id (1)), "'" write (u, "(A,A,A)") "proc_id(2) = '", char (prc_set%get_proc_id (2)), "'" write (u, "(A)") write (u, "(A)") "* Process library" write (u, "(A)") call prc_set%compile_library (global) lib => global%prclib_stack%get_library_ptr (libname) if (associated (lib)) call lib%write (u, libpath=.false.) write (u, *) write (u, "(A)") "* Cleanup" call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: restricted_subprocesses_2" end subroutine restricted_subprocesses_2 @ %def restricted_subprocesses_2 @ \subsubsection{Auxiliary: Test processes} Auxiliary subroutine that constructs the process library for the above test. This parallels a similar subroutine in [[processes_uti]], but this time we want an \oMega\ process. <>= public :: prepare_resonance_test_library <>= subroutine prepare_resonance_test_library & (lib, libname, procname, model, global, u) type(process_library_t), target, intent(out) :: lib type(string_t), intent(in) :: libname type(string_t), intent(in) :: procname class(model_data_t), intent(in), pointer :: model type(rt_data_t), intent(in), target :: global integer, intent(in) :: u type(string_t), dimension(:), allocatable :: prt_in, prt_out class(prc_core_def_t), allocatable :: def type(process_def_entry_t), pointer :: entry call lib%init (libname) allocate (prt_in (2), prt_out (3)) prt_in = [var_str ("e+"), var_str ("e-")] prt_out = [var_str ("d"), var_str ("ubar"), var_str ("W+")] allocate (omega_def_t :: def) select type (def) type is (omega_def_t) call def%init (model%get_name (), prt_in, prt_out, & ovm=.false., ufo=.false.) end select allocate (entry) call entry%init (procname, & model_name = model%get_name (), & n_in = 2, n_components = 1, & requires_resonances = .true.) call entry%import_component (1, n_out = size (prt_out), & prt_in = new_prt_spec (prt_in), & prt_out = new_prt_spec (prt_out), & method = var_str ("omega"), & variant = def) call entry%write (u) call lib%append (entry) call lib%configure (global%os_data) call lib%write_makefile (global%os_data, force = .true., verbose = .false.) call lib%clean (global%os_data, distclean = .false.) call lib%write_driver (force = .true.) call lib%load (global%os_data) end subroutine prepare_resonance_test_library @ %def prepare_resonance_test_library @ \subsubsection{Kinematics and resonance selection} Prepare an actual process with resonant subprocesses. Insert kinematics and apply the resonance selector in an associated event transform. <>= call test (restricted_subprocesses_3, "restricted_subprocesses_3", & "resonance kinematics and probability", & u, results) <>= public :: restricted_subprocesses_3 <>= subroutine restricted_subprocesses_3 (u) integer, intent(in) :: u type(rt_data_t), target :: global class(model_t), pointer :: model class(model_data_t), pointer :: model_data type(string_t) :: libname, libname_res type(string_t) :: procname type(process_component_def_t), pointer :: process_component_def type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib logical :: exist type(process_t), pointer :: process type(process_instance_t), target :: process_instance type(resonance_history_set_t), dimension(1) :: res_history_set type(resonant_subprocess_set_t) :: prc_set type(particle_set_t) :: pset real(default) :: sqrts, mw, pp real(default), dimension(3) :: p3 type(vector4_t), dimension(:), allocatable :: p real(default), dimension(:), allocatable :: m integer, dimension(:), allocatable :: pdg real(default), dimension(:), allocatable :: sqme logical, dimension(:), allocatable :: mask real(default) :: on_shell_limit integer, dimension(:), allocatable :: i_array real(default), dimension(:), allocatable :: prob_array type(evt_resonance_t), target :: evt_resonance integer :: i, u_dump write (u, "(A)") "* Test output: restricted_subprocesses_3" write (u, "(A)") "* Purpose: handle process and resonance kinematics" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () call global%global_init () call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%set_log (var_str ("?resonance_history"), & .true., is_known = .true.) call global%select_model (var_str ("SM")) allocate (model) call model%init_instance (global%model) model_data => model libname = "restricted_subprocesses_3_lib" libname_res = "restricted_subprocesses_3_lib_res" procname = "restricted_subprocesses_3_p" write (u, "(A)") "* Initialize process library and process" write (u, "(A)") allocate (lib_entry) call lib_entry%init (libname) lib => lib_entry%process_library_t call global%add_prclib (lib_entry) call prepare_resonance_test_library & (lib, libname, procname, model_data, global, u) call integrate_process (procname, global, & local_stack = .true., init_only = .true.) process => global%process_stack%get_process_ptr (procname) call process_instance%init (process) call process_instance%setup_event_data () write (u, "(A)") write (u, "(A)") "* Extract resonance history set" write (u, "(A)") call process%extract_resonance_history_set & (res_history_set(1), include_trivial=.true., i_component=1) call res_history_set(1)%write (u) write (u, "(A)") write (u, "(A)") "* Build resonant-subprocess library" write (u, "(A)") call prc_set%init (1) call prc_set%fill_resonances (res_history_set(1), 1) process_component_def => process%get_component_def_ptr (1) call prc_set%create_library (libname_res, global, exist) if (.not. exist) then call prc_set%add_to_library (1, & process_component_def%get_prt_spec_in (), & process_component_def%get_prt_spec_out (), & global) end if call prc_set%freeze_library (global) call prc_set%compile_library (global) call prc_set%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Build particle set" write (u, "(A)") sqrts = global%get_rval (var_str ("sqrts")) mw = 80._default ! deliberately slightly different from true mw pp = sqrt (sqrts**2 - 4 * mw**2) / 2 allocate (pdg (5), p (5), m (5)) pdg(1) = -11 p(1) = vector4_moving (sqrts/2, sqrts/2, 3) m(1) = 0 pdg(2) = 11 p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) m(2) = 0 pdg(3) = 1 p3(1) = pp/2 p3(2) = mw/2 p3(3) = 0 p(3) = vector4_moving (sqrts/4, vector3_moving (p3)) m(3) = 0 p3(2) = -mw/2 pdg(4) = -2 p(4) = vector4_moving (sqrts/4, vector3_moving (p3)) m(4) = 0 pdg(5) = 24 p(5) = vector4_moving (sqrts/2,-pp, 1) m(5) = mw call pset%init_direct (0, 2, 0, 0, 3, pdg, model) call pset%set_momentum (p, m**2) call pset%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Fill process instance" ! workflow from event_recalculate call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1) call process_instance%recover & (1, 1, update_sqme=.true., recover_phs=.false.) call process_instance%evaluate_event_data (weight = 1._default) write (u, "(A)") write (u, "(A)") "* Prepare resonant subprocesses" call prc_set%prepare_process_objects (global) call prc_set%prepare_process_instances (global) call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call prc_set%connect_transform (evt_resonance) call evt_resonance%connect (process_instance, model) call prc_set%fill_momenta () write (u, "(A)") write (u, "(A)") "* Show squared matrix element of master process," write (u, "(A)") " should coincide with 2nd subprocess sqme" write (u, "(A)") write (u, "(1x,I0,1x," // FMT_12 // ")") 0, prc_set%get_master_sqme () write (u, "(A)") write (u, "(A)") "* Compute squared matrix elements & &of selected resonant subprocesses [1,2]" write (u, "(A)") call prc_set%evaluate_subprocess ([1,2]) allocate (sqme (3), source = 0._default) call prc_set%get_subprocess_sqme (sqme) do i = 1, size (sqme) write (u, "(1x,I0,1x," // FMT_12 // ")") i, sqme(i) end do deallocate (sqme) write (u, "(A)") write (u, "(A)") "* Compute squared matrix elements & &of all resonant subprocesses" write (u, "(A)") call prc_set%evaluate_subprocess ([1,2,3]) allocate (sqme (3), source = 0._default) call prc_set%get_subprocess_sqme (sqme) do i = 1, size (sqme) write (u, "(1x,I0,1x," // FMT_12 // ")") i, sqme(i) end do deallocate (sqme) write (u, "(A)") write (u, "(A)") "* Write process instances to file & &restricted_subprocesses_3_lib_res.dat" u_dump = free_unit () open (unit = u_dump, file = "restricted_subprocesses_3_lib_res.dat", & action = "write", status = "replace") call prc_set%dump_instances (u_dump) close (u_dump) write (u, "(A)") write (u, "(A)") "* Determine on-shell resonant subprocesses" write (u, "(A)") on_shell_limit = 0 write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit call prc_set%set_on_shell_limit (on_shell_limit) call prc_set%determine_on_shell_histories (1, i_array) write (u, "(1x,A,9(1x,I0))") "resonant =", i_array on_shell_limit = 0.1_default write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit call prc_set%set_on_shell_limit (on_shell_limit) call prc_set%determine_on_shell_histories (1, i_array) write (u, "(1x,A,9(1x,I0))") "resonant =", i_array on_shell_limit = 10._default write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit call prc_set%set_on_shell_limit (on_shell_limit) call prc_set%determine_on_shell_histories (1, i_array) write (u, "(1x,A,9(1x,I0))") "resonant =", i_array on_shell_limit = 10000._default write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit call prc_set%set_on_shell_limit (on_shell_limit) call prc_set%determine_on_shell_histories (1, i_array) write (u, "(1x,A,9(1x,I0))") "resonant =", i_array write (u, "(A)") write (u, "(A)") "* Compute probabilities for applicable resonances" write (u, "(A)") " and initialize the process selector" write (u, "(A)") " (The first number is the probability for background)" write (u, "(A)") on_shell_limit = 0 write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit call prc_set%set_on_shell_limit (on_shell_limit) call prc_set%determine_on_shell_histories (1, i_array) call prc_set%compute_probabilities (prob_array) write (u, "(1x,A,9(1x,"// FMT_12 // "))") "resonant =", prob_array call prc_set%write (u, testflag=.true.) write (u, *) on_shell_limit = 10._default write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit call prc_set%set_on_shell_limit (on_shell_limit) call prc_set%determine_on_shell_histories (1, i_array) call prc_set%compute_probabilities (prob_array) write (u, "(1x,A,9(1x,"// FMT_12 // "))") "resonant =", prob_array call prc_set%write (u, testflag=.true.) write (u, *) on_shell_limit = 10000._default write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit call prc_set%set_on_shell_limit (on_shell_limit) call prc_set%determine_on_shell_histories (1, i_array) call prc_set%compute_probabilities (prob_array) write (u, "(1x,A,9(1x,"// FMT_12 // "))") "resonant =", prob_array write (u, *) call prc_set%write (u, testflag=.true.) write (u, *) write (u, "(A)") "* Cleanup" call global%final () call syntax_phs_forest_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: restricted_subprocesses_3" end subroutine restricted_subprocesses_3 @ %def restricted_subprocesses_3 @ \subsubsection{Event transform} Prepare an actual process with resonant subprocesses. Prepare the resonance selector for a fixed event and apply the resonance-insertion event transform. <>= call test (restricted_subprocesses_4, "restricted_subprocesses_4", & "event transform", & u, results) <>= public :: restricted_subprocesses_4 <>= subroutine restricted_subprocesses_4 (u) integer, intent(in) :: u type(rt_data_t), target :: global class(model_t), pointer :: model class(model_data_t), pointer :: model_data type(string_t) :: libname, libname_res type(string_t) :: procname type(process_component_def_t), pointer :: process_component_def type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib logical :: exist type(process_t), pointer :: process type(process_instance_t), target :: process_instance type(resonance_history_set_t), dimension(1) :: res_history_set type(resonant_subprocess_set_t) :: prc_set type(particle_set_t) :: pset real(default) :: sqrts, mw, pp real(default), dimension(3) :: p3 type(vector4_t), dimension(:), allocatable :: p real(default), dimension(:), allocatable :: m integer, dimension(:), allocatable :: pdg real(default) :: on_shell_limit type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance real(default) :: probability integer :: i write (u, "(A)") "* Test output: restricted_subprocesses_4" write (u, "(A)") "* Purpose: employ event transform" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () call global%global_init () call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%set_log (var_str ("?resonance_history"), & .true., is_known = .true.) call global%select_model (var_str ("SM")) allocate (model) call model%init_instance (global%model) model_data => model libname = "restricted_subprocesses_4_lib" libname_res = "restricted_subprocesses_4_lib_res" procname = "restricted_subprocesses_4_p" write (u, "(A)") "* Initialize process library and process" write (u, "(A)") allocate (lib_entry) call lib_entry%init (libname) lib => lib_entry%process_library_t call global%add_prclib (lib_entry) call prepare_resonance_test_library & (lib, libname, procname, model_data, global, u) call integrate_process (procname, global, & local_stack = .true., init_only = .true.) process => global%process_stack%get_process_ptr (procname) call process_instance%init (process) call process_instance%setup_event_data () write (u, "(A)") write (u, "(A)") "* Extract resonance history set" call process%extract_resonance_history_set & (res_history_set(1), include_trivial=.false., i_component=1) write (u, "(A)") write (u, "(A)") "* Build resonant-subprocess library" call prc_set%init (1) call prc_set%fill_resonances (res_history_set(1), 1) process_component_def => process%get_component_def_ptr (1) call prc_set%create_library (libname_res, global, exist) if (.not. exist) then call prc_set%add_to_library (1, & process_component_def%get_prt_spec_in (), & process_component_def%get_prt_spec_out (), & global) end if call prc_set%freeze_library (global) call prc_set%compile_library (global) write (u, "(A)") write (u, "(A)") "* Build particle set" write (u, "(A)") sqrts = global%get_rval (var_str ("sqrts")) mw = 80._default ! deliberately slightly different from true mw pp = sqrt (sqrts**2 - 4 * mw**2) / 2 allocate (pdg (5), p (5), m (5)) pdg(1) = -11 p(1) = vector4_moving (sqrts/2, sqrts/2, 3) m(1) = 0 pdg(2) = 11 p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) m(2) = 0 pdg(3) = 1 p3(1) = pp/2 p3(2) = mw/2 p3(3) = 0 p(3) = vector4_moving (sqrts/4, vector3_moving (p3)) m(3) = 0 p3(2) = -mw/2 pdg(4) = -2 p(4) = vector4_moving (sqrts/4, vector3_moving (p3)) m(4) = 0 pdg(5) = 24 p(5) = vector4_moving (sqrts/2,-pp, 1) m(5) = mw call pset%init_direct (0, 2, 0, 0, 3, pdg, model) call pset%set_momentum (p, m**2) write (u, "(A)") "* Fill process instance" write (u, "(A)") ! workflow from event_recalculate call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1) call process_instance%recover & (1, 1, update_sqme=.true., recover_phs=.false.) call process_instance%evaluate_event_data (weight = 1._default) write (u, "(A)") "* Prepare resonant subprocesses" write (u, "(A)") call prc_set%prepare_process_objects (global) call prc_set%prepare_process_instances (global) write (u, "(A)") "* Fill trivial event transform (deliberately w/o color)" write (u, "(A)") call evt_trivial%connect (process_instance, model) call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) write (u, "(A)") write (u, "(A)") "* Initialize resonance-insertion event transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call evt_resonance%connect (process_instance, model) call prc_set%connect_transform (evt_resonance) call evt_resonance%write (u) write (u, "(A)") write (u, "(A)") "* Compute probabilities for applicable resonances" write (u, "(A)") " and initialize the process selector" write (u, "(A)") on_shell_limit = 10._default write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit call evt_resonance%set_on_shell_limit (on_shell_limit) write (u, "(A)") write (u, "(A)") "* Evaluate resonance-insertion event transform" write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (1, .false.) call evt_resonance%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_phs_forest_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: restricted_subprocesses_4" end subroutine restricted_subprocesses_4 @ %def restricted_subprocesses_4 @ \subsubsection{Gaussian turnoff} Identical to the previous process, except that we apply a Gaussian turnoff to the resonance kinematics, which affects the subprocess selector. <>= call test (restricted_subprocesses_5, "restricted_subprocesses_5", & "event transform with gaussian turnoff", & u, results) <>= public :: restricted_subprocesses_5 <>= subroutine restricted_subprocesses_5 (u) integer, intent(in) :: u type(rt_data_t), target :: global class(model_t), pointer :: model class(model_data_t), pointer :: model_data type(string_t) :: libname, libname_res type(string_t) :: procname type(process_component_def_t), pointer :: process_component_def type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib logical :: exist type(process_t), pointer :: process type(process_instance_t), target :: process_instance type(resonance_history_set_t), dimension(1) :: res_history_set type(resonant_subprocess_set_t) :: prc_set type(particle_set_t) :: pset real(default) :: sqrts, mw, pp real(default), dimension(3) :: p3 type(vector4_t), dimension(:), allocatable :: p real(default), dimension(:), allocatable :: m integer, dimension(:), allocatable :: pdg real(default) :: on_shell_limit real(default) :: on_shell_turnoff type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance real(default) :: probability integer :: i write (u, "(A)") "* Test output: restricted_subprocesses_5" write (u, "(A)") "* Purpose: employ event transform & &with gaussian turnoff" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () call global%global_init () call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%set_log (var_str ("?resonance_history"), & .true., is_known = .true.) call global%select_model (var_str ("SM")) allocate (model) call model%init_instance (global%model) model_data => model libname = "restricted_subprocesses_5_lib" libname_res = "restricted_subprocesses_5_lib_res" procname = "restricted_subprocesses_5_p" write (u, "(A)") "* Initialize process library and process" write (u, "(A)") allocate (lib_entry) call lib_entry%init (libname) lib => lib_entry%process_library_t call global%add_prclib (lib_entry) call prepare_resonance_test_library & (lib, libname, procname, model_data, global, u) call integrate_process (procname, global, & local_stack = .true., init_only = .true.) process => global%process_stack%get_process_ptr (procname) call process_instance%init (process) call process_instance%setup_event_data () write (u, "(A)") write (u, "(A)") "* Extract resonance history set" call process%extract_resonance_history_set & (res_history_set(1), include_trivial=.false., i_component=1) write (u, "(A)") write (u, "(A)") "* Build resonant-subprocess library" call prc_set%init (1) call prc_set%fill_resonances (res_history_set(1), 1) process_component_def => process%get_component_def_ptr (1) call prc_set%create_library (libname_res, global, exist) if (.not. exist) then call prc_set%add_to_library (1, & process_component_def%get_prt_spec_in (), & process_component_def%get_prt_spec_out (), & global) end if call prc_set%freeze_library (global) call prc_set%compile_library (global) write (u, "(A)") write (u, "(A)") "* Build particle set" write (u, "(A)") sqrts = global%get_rval (var_str ("sqrts")) mw = 80._default ! deliberately slightly different from true mw pp = sqrt (sqrts**2 - 4 * mw**2) / 2 allocate (pdg (5), p (5), m (5)) pdg(1) = -11 p(1) = vector4_moving (sqrts/2, sqrts/2, 3) m(1) = 0 pdg(2) = 11 p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) m(2) = 0 pdg(3) = 1 p3(1) = pp/2 p3(2) = mw/2 p3(3) = 0 p(3) = vector4_moving (sqrts/4, vector3_moving (p3)) m(3) = 0 p3(2) = -mw/2 pdg(4) = -2 p(4) = vector4_moving (sqrts/4, vector3_moving (p3)) m(4) = 0 pdg(5) = 24 p(5) = vector4_moving (sqrts/2,-pp, 1) m(5) = mw call pset%init_direct (0, 2, 0, 0, 3, pdg, model) call pset%set_momentum (p, m**2) write (u, "(A)") "* Fill process instance" write (u, "(A)") ! workflow from event_recalculate call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1) call process_instance%recover & (1, 1, update_sqme=.true., recover_phs=.false.) call process_instance%evaluate_event_data (weight = 1._default) write (u, "(A)") "* Prepare resonant subprocesses" write (u, "(A)") call prc_set%prepare_process_objects (global) call prc_set%prepare_process_instances (global) write (u, "(A)") "* Fill trivial event transform (deliberately w/o color)" write (u, "(A)") call evt_trivial%connect (process_instance, model) call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) write (u, "(A)") write (u, "(A)") "* Initialize resonance-insertion event transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call evt_resonance%connect (process_instance, model) call prc_set%connect_transform (evt_resonance) call evt_resonance%write (u) write (u, "(A)") write (u, "(A)") "* Compute probabilities for applicable resonances" write (u, "(A)") " and initialize the process selector" write (u, "(A)") on_shell_limit = 10._default write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", & on_shell_limit call evt_resonance%set_on_shell_limit (on_shell_limit) on_shell_turnoff = 1._default write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_turnoff =", & on_shell_turnoff call evt_resonance%set_on_shell_turnoff (on_shell_turnoff) write (u, "(A)") write (u, "(A)") "* Evaluate resonance-insertion event transform" write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (1, .false.) call evt_resonance%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_phs_forest_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: restricted_subprocesses_5" end subroutine restricted_subprocesses_5 @ %def restricted_subprocesses_5 @ \subsubsection{Event transform} The same process and event again. This time, switch off the background contribution, so the selector becomes trivial. <>= call test (restricted_subprocesses_6, "restricted_subprocesses_6", & "event transform with background switched off", & u, results) <>= public :: restricted_subprocesses_6 <>= subroutine restricted_subprocesses_6 (u) integer, intent(in) :: u type(rt_data_t), target :: global class(model_t), pointer :: model class(model_data_t), pointer :: model_data type(string_t) :: libname, libname_res type(string_t) :: procname type(process_component_def_t), pointer :: process_component_def type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib logical :: exist type(process_t), pointer :: process type(process_instance_t), target :: process_instance type(resonance_history_set_t), dimension(1) :: res_history_set type(resonant_subprocess_set_t) :: prc_set type(particle_set_t) :: pset real(default) :: sqrts, mw, pp real(default), dimension(3) :: p3 type(vector4_t), dimension(:), allocatable :: p real(default), dimension(:), allocatable :: m integer, dimension(:), allocatable :: pdg real(default) :: on_shell_limit real(default) :: background_factor type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance real(default) :: probability integer :: i write (u, "(A)") "* Test output: restricted_subprocesses_6" write (u, "(A)") "* Purpose: employ event transform & &with background switched off" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () call global%global_init () call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%set_log (var_str ("?resonance_history"), & .true., is_known = .true.) call global%select_model (var_str ("SM")) allocate (model) call model%init_instance (global%model) model_data => model libname = "restricted_subprocesses_6_lib" libname_res = "restricted_subprocesses_6_lib_res" procname = "restricted_subprocesses_6_p" write (u, "(A)") "* Initialize process library and process" write (u, "(A)") allocate (lib_entry) call lib_entry%init (libname) lib => lib_entry%process_library_t call global%add_prclib (lib_entry) call prepare_resonance_test_library & (lib, libname, procname, model_data, global, u) call integrate_process (procname, global, & local_stack = .true., init_only = .true.) process => global%process_stack%get_process_ptr (procname) call process_instance%init (process) call process_instance%setup_event_data () write (u, "(A)") write (u, "(A)") "* Extract resonance history set" call process%extract_resonance_history_set & (res_history_set(1), include_trivial=.false., i_component=1) write (u, "(A)") write (u, "(A)") "* Build resonant-subprocess library" call prc_set%init (1) call prc_set%fill_resonances (res_history_set(1), 1) process_component_def => process%get_component_def_ptr (1) call prc_set%create_library (libname_res, global, exist) if (.not. exist) then call prc_set%add_to_library (1, & process_component_def%get_prt_spec_in (), & process_component_def%get_prt_spec_out (), & global) end if call prc_set%freeze_library (global) call prc_set%compile_library (global) write (u, "(A)") write (u, "(A)") "* Build particle set" write (u, "(A)") sqrts = global%get_rval (var_str ("sqrts")) mw = 80._default ! deliberately slightly different from true mw pp = sqrt (sqrts**2 - 4 * mw**2) / 2 allocate (pdg (5), p (5), m (5)) pdg(1) = -11 p(1) = vector4_moving (sqrts/2, sqrts/2, 3) m(1) = 0 pdg(2) = 11 p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) m(2) = 0 pdg(3) = 1 p3(1) = pp/2 p3(2) = mw/2 p3(3) = 0 p(3) = vector4_moving (sqrts/4, vector3_moving (p3)) m(3) = 0 p3(2) = -mw/2 pdg(4) = -2 p(4) = vector4_moving (sqrts/4, vector3_moving (p3)) m(4) = 0 pdg(5) = 24 p(5) = vector4_moving (sqrts/2,-pp, 1) m(5) = mw call pset%init_direct (0, 2, 0, 0, 3, pdg, model) call pset%set_momentum (p, m**2) write (u, "(A)") "* Fill process instance" write (u, "(A)") ! workflow from event_recalculate call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1) call process_instance%recover & (1, 1, update_sqme=.true., recover_phs=.false.) call process_instance%evaluate_event_data (weight = 1._default) write (u, "(A)") "* Prepare resonant subprocesses" write (u, "(A)") call prc_set%prepare_process_objects (global) call prc_set%prepare_process_instances (global) write (u, "(A)") "* Fill trivial event transform (deliberately w/o color)" write (u, "(A)") call evt_trivial%connect (process_instance, model) call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) write (u, "(A)") write (u, "(A)") "* Initialize resonance-insertion event transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call evt_resonance%connect (process_instance, model) call prc_set%connect_transform (evt_resonance) call evt_resonance%write (u) write (u, "(A)") write (u, "(A)") "* Compute probabilities for applicable resonances" write (u, "(A)") " and initialize the process selector" write (u, "(A)") on_shell_limit = 10._default write (u, "(1x,A,1x," // FMT_10 // ")") & "on_shell_limit =", on_shell_limit call evt_resonance%set_on_shell_limit (on_shell_limit) background_factor = 0 write (u, "(1x,A,1x," // FMT_10 // ")") & "background_factor =", background_factor call evt_resonance%set_background_factor (background_factor) write (u, "(A)") write (u, "(A)") "* Evaluate resonance-insertion event transform" write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (1, .false.) call evt_resonance%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () call syntax_phs_forest_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: restricted_subprocesses_6" end subroutine restricted_subprocesses_6 @ %def restricted_subprocesses_6 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Simulation} This module manages simulation: event generation and reading/writing of event files. The [[simulation]] object is intended to be used (via a pointer) outside of \whizard, if events are generated individually by an external driver. <<[[simulations.f90]]>>= <> module simulations <> <> use io_units use format_utils, only: write_separator use format_defs, only: FMT_15, FMT_19 use os_interface use numeric_utils use string_utils, only: str use diagnostics use lorentz, only: vector4_t use sm_qcd use md5 use variables, only: var_list_t use eval_trees use model_data use flavors use particles use state_matrices, only: FM_IGNORE_HELICITY use beam_structures, only: beam_structure_t use beams use rng_base use rng_stream, only: rng_stream_t use selectors use resonances, only: resonance_history_set_t use process_libraries, only: process_library_t use process_libraries, only: process_component_def_t use prc_core ! TODO: (bcn 2016-09-13) should be ideally only pcm_base use pcm, only: pcm_nlo_t, pcm_instance_nlo_t ! TODO: (bcn 2016-09-13) details of process config should not be necessary here use process_config, only: COMP_REAL_FIN use process use instances use event_base use events use event_transforms use shower use eio_data use eio_base use rt_data use dispatch_beams, only: dispatch_qcd use dispatch_rng, only: dispatch_rng_factory use dispatch_rng, only: update_rng_seed_in_var_list use dispatch_me_methods, only: dispatch_core_update, dispatch_core_restore use dispatch_transforms, only: dispatch_evt_isr_epa_handler use dispatch_transforms, only: dispatch_evt_resonance use dispatch_transforms, only: dispatch_evt_decay use dispatch_transforms, only: dispatch_evt_shower use dispatch_transforms, only: dispatch_evt_hadrons use dispatch_transforms, only: dispatch_evt_nlo use integrations use event_streams use restricted_subprocesses, only: resonant_subprocess_set_t use restricted_subprocesses, only: get_libname_res use evt_nlo <> <> <> <> <> contains <> end module simulations @ %def simulations @ \subsection{Event counting} In this object we collect statistical information about an event sample or sub-sample. <>= type :: counter_t integer :: total = 0 integer :: generated = 0 integer :: read = 0 integer :: positive = 0 integer :: negative = 0 integer :: zero = 0 integer :: excess = 0 integer :: dropped = 0 real(default) :: max_excess = 0 real(default) :: sum_excess = 0 logical :: reproduce_xsection = .false. real(default) :: mean = 0 real(default) :: varsq = 0 integer :: nlo_weight_counter = 0 contains <> end type counter_t @ %def simulation_counter_t @ Output. <>= procedure :: write => counter_write <>= subroutine counter_write (counter, unit) class(counter_t), intent(in) :: counter integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) 1 format (3x,A,I0) 2 format (5x,A,I0) 3 format (5x,A,ES19.12) write (u, 1) "Events total = ", counter%total write (u, 2) "generated = ", counter%generated write (u, 2) "read = ", counter%read write (u, 2) "positive weight = ", counter%positive write (u, 2) "negative weight = ", counter%negative write (u, 2) "zero weight = ", counter%zero write (u, 2) "excess weight = ", counter%excess if (counter%excess /= 0) then write (u, 3) "max excess = ", counter%max_excess write (u, 3) "avg excess = ", counter%sum_excess / counter%total end if write (u, 1) "Events dropped = ", counter%dropped end subroutine counter_write @ %def counter_write @ This is a screen message: if there was an excess, display statistics. <>= procedure :: show_excess => counter_show_excess <>= subroutine counter_show_excess (counter) class(counter_t), intent(in) :: counter if (counter%excess > 0) then write (msg_buffer, "(A,1x,I0,1x,A,1x,'(',F7.3,' %)')") & "Encountered events with excess weight:", counter%excess, & "events", 100 * counter%excess / real (counter%total) call msg_warning () write (msg_buffer, "(A,ES10.3)") & "Maximum excess weight =", counter%max_excess call msg_message () write (msg_buffer, "(A,ES10.3)") & "Average excess weight =", counter%sum_excess / counter%total call msg_message () end if end subroutine counter_show_excess @ %def counter_show_excess @ If events have been dropped during simulation of weighted events, issue a message here. <>= procedure :: show_dropped => counter_show_dropped <>= subroutine counter_show_dropped (counter) class(counter_t), intent(in) :: counter if (counter%dropped > 0) then write (msg_buffer, "(A,1x,I0,1x,'(',A,1x,I0,')')") & "Dropped events (weight zero) =", & counter%dropped, "total", counter%dropped + counter%total call msg_message () write (msg_buffer, "(A,ES15.8)") & "All event weights must be rescaled by f =", & real (counter%total, default) & / real (counter%dropped + counter%total, default) call msg_warning () end if end subroutine counter_show_dropped @ %def counter_show_dropped @ <>= procedure :: show_mean_and_variance => counter_show_mean_and_variance <>= subroutine counter_show_mean_and_variance (counter) class(counter_t), intent(in) :: counter if (counter%reproduce_xsection .and. counter%nlo_weight_counter > 1) then print *, "Reconstructed cross-section from event weights: " print *, counter%mean, '+-', sqrt (counter%varsq / (counter%nlo_weight_counter - 1)) end if end subroutine counter_show_mean_and_variance @ %def counter_show_mean_and_variance @ Count an event. The weight and event source are optional; by default we assume that the event has been generated and has positive weight. The optional integer [[n_dropped]] counts weighted events with weight zero that were encountered while generating the current event, but dropped (because of their zero weight). Accumulating this number allows for renormalizing event weight sums in histograms, after the generation step has been completed. <>= procedure :: record => counter_record <>= subroutine counter_record (counter, weight, excess, n_dropped, from_file) class(counter_t), intent(inout) :: counter real(default), intent(in), optional :: weight, excess integer, intent(in), optional :: n_dropped logical, intent(in), optional :: from_file counter%total = counter%total + 1 if (present (from_file)) then if (from_file) then counter%read = counter%read + 1 else counter%generated = counter%generated + 1 end if else counter%generated = counter%generated + 1 end if if (present (weight)) then if (weight > 0) then counter%positive = counter%positive + 1 else if (weight < 0) then counter%negative = counter%negative + 1 else counter%zero = counter%zero + 1 end if else counter%positive = counter%positive + 1 end if if (present (excess)) then if (excess > 0) then counter%excess = counter%excess + 1 counter%max_excess = max (counter%max_excess, excess) counter%sum_excess = counter%sum_excess + excess end if end if if (present (n_dropped)) then counter%dropped = counter%dropped + n_dropped end if end subroutine counter_record @ %def counter_record @ <>= procedure :: record_mean_and_variance => & counter_record_mean_and_variance <>= subroutine counter_record_mean_and_variance (counter, weight, i_nlo) class(counter_t), intent(inout) :: counter real(default), intent(in) :: weight integer, intent(in) :: i_nlo real(default), save :: weight_buffer = 0._default integer, save :: nlo_count = 1 if (.not. counter%reproduce_xsection) return if (i_nlo == 1) then call flush_weight_buffer (weight_buffer, nlo_count) weight_buffer = weight nlo_count = 1 else weight_buffer = weight_buffer + weight nlo_count = nlo_count + 1 end if contains subroutine flush_weight_buffer (w, n_nlo) real(default), intent(in) :: w integer, intent(in) :: n_nlo integer :: n real(default) :: mean_new counter%nlo_weight_counter = counter%nlo_weight_counter + 1 !!! Minus 1 to take into account offset from initialization n = counter%nlo_weight_counter - 1 if (n > 0) then mean_new = counter%mean + (w / n_nlo - counter%mean) / n if (n > 1) & counter%varsq = counter%varsq - counter%varsq / (n - 1) + & n * (mean_new - counter%mean)**2 counter%mean = mean_new end if end subroutine flush_weight_buffer end subroutine counter_record_mean_and_variance @ %def counter_record_mean_and_variance @ \subsection{Simulation: component sets} For each set of process components that share a MCI entry in the process configuration, we keep a separate event record. <>= type :: mci_set_t private integer :: n_components = 0 integer, dimension(:), allocatable :: i_component type(string_t), dimension(:), allocatable :: component_id logical :: has_integral = .false. real(default) :: integral = 0 real(default) :: error = 0 real(default) :: weight_mci = 0 type(counter_t) :: counter contains <> end type mci_set_t @ %def mci_set_t @ Output. <>= procedure :: write => mci_set_write <>= subroutine mci_set_write (object, unit, pacified) class(mci_set_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacified logical :: pacify integer :: u, i u = given_output_unit (unit) pacify = .false.; if (present (pacified)) pacify = pacified write (u, "(3x,A)") "Components:" do i = 1, object%n_components write (u, "(5x,I0,A,A,A)") object%i_component(i), & ": '", char (object%component_id(i)), "'" end do if (object%has_integral) then if (pacify) then write (u, "(3x,A," // FMT_15 // ")") "Integral = ", object%integral write (u, "(3x,A," // FMT_15 // ")") "Error = ", object%error write (u, "(3x,A,F9.6)") "Weight =", object%weight_mci else write (u, "(3x,A," // FMT_19 // ")") "Integral = ", object%integral write (u, "(3x,A," // FMT_19 // ")") "Error = ", object%error write (u, "(3x,A,F13.10)") "Weight =", object%weight_mci end if else write (u, "(3x,A)") "Integral = [undefined]" end if call object%counter%write (u) end subroutine mci_set_write @ %def mci_set_write @ Initialize: Get the indices and names for the process components that will contribute to this set. <>= procedure :: init => mci_set_init <>= subroutine mci_set_init (object, i_mci, process) class(mci_set_t), intent(out) :: object integer, intent(in) :: i_mci type(process_t), intent(in), target :: process integer :: i call process%get_i_component (i_mci, object%i_component) object%n_components = size (object%i_component) allocate (object%component_id (object%n_components)) do i = 1, size (object%component_id) object%component_id(i) = & process%get_component_id (object%i_component(i)) end do if (process%has_integral (i_mci)) then object%integral = process%get_integral (i_mci) object%error = process%get_error (i_mci) object%has_integral = .true. end if end subroutine mci_set_init @ %def mci_set_init @ \subsection{Process-core Safe} This is an object that temporarily holds a process core object. We need this while rescanning a process with modified parameters. After the rescan, we want to restore the original state. <>= type :: core_safe_t class(prc_core_t), allocatable :: core end type core_safe_t @ %def core_safe_t @ \subsection{Process Object} The simulation works on process objects. This subroutine makes a process object available for simulation. The process is in the process stack. [[use_process]] implies that the process should already exist as an object in the process stack. If integration is not yet done, do it. Any generated process object should be put on the global stack, if it is separate from the local one. <>= subroutine prepare_process & (process, process_id, use_process, integrate, local, global) type(process_t), pointer, intent(out) :: process type(string_t), intent(in) :: process_id logical, intent(in) :: use_process, integrate type(rt_data_t), intent(inout), target :: local type(rt_data_t), intent(inout), optional, target :: global type(rt_data_t), pointer :: current call msg_debug (D_CORE, "prepare_process") call msg_debug (D_CORE, "global present", present (global)) if (present (global)) then current => global else current => local end if process => current%process_stack%get_process_ptr (process_id) call msg_debug (D_CORE, "use_process", use_process) call msg_debug (D_CORE, "associated process", associated (process)) if (use_process .and. .not. associated (process)) then if (integrate) then call msg_message ("Simulate: process '" & // char (process_id) // "' needs integration") else call msg_message ("Simulate: process '" & // char (process_id) // "' needs initialization") end if if (present (global)) then call integrate_process (process_id, local, global, & init_only = .not. integrate) else call integrate_process (process_id, local, & local_stack = .true., init_only = .not. integrate) end if if (signal_is_pending ()) return process => current%process_stack%get_process_ptr (process_id) if (associated (process)) then if (integrate) then call msg_message ("Simulate: integration done") call current%process_stack%fill_result_vars (process_id) else call msg_message ("Simulate: process initialization done") end if else call msg_fatal ("Simulate: process '" & // char (process_id) // "' could not be initialized: aborting") end if else if (.not. associated (process)) then if (present (global)) then call integrate_process (process_id, local, global, & init_only = .true.) else call integrate_process (process_id, local, & local_stack = .true., init_only = .true.) end if process => current%process_stack%get_process_ptr (process_id) call msg_message & ("Simulate: process '" & // char (process_id) // "': enabled for rescan only") end if end subroutine prepare_process @ %def prepare_process @ \subsection{Simulation entry} For each process that we consider for event generation, we need a separate entry. The entry separately records the process ID and run ID. The [[weight_mci]] array is used for selecting a component set (which shares a MCI record inside the process container) when generating an event for the current process. The simulation entry is an extension of the [[event_t]] event record. This core object contains configuration data, pointers to the process and process instance, the expressions, flags and values that are evaluated at runtime, and the resulting particle set. The entry explicitly allocate the [[process_instance]], which becomes the process-specific workspace for the event record. If entries with differing environments are present simultaneously, we may need to switch QCD parameters and/or the model event by event. In this case, the [[qcd]] and/or [[model]] components are present.\\ For the puropose of NLO events, [[entry_t]] contains a pointer list to other simulation-entries. This is due to the fact that we have to associate an event for each component of the fixed order simulation, i.e. one $N$-particle event and $N_\alpha$ $N+1$-particle events. However, all entries share the same event transforms. <>= type, extends (event_t) :: entry_t private type(string_t) :: process_id type(string_t) :: library type(string_t) :: run_id logical :: has_integral = .false. real(default) :: integral = 0 real(default) :: error = 0 real(default) :: process_weight = 0 logical :: valid = .false. type(counter_t) :: counter integer :: n_in = 0 integer :: n_mci = 0 type(mci_set_t), dimension(:), allocatable :: mci_sets type(selector_t) :: mci_selector logical :: has_resonant_subprocess_set = .false. type(resonant_subprocess_set_t) :: resonant_subprocess_set type(core_safe_t), dimension(:), allocatable :: core_safe class(model_data_t), pointer :: model => null () type(qcd_t) :: qcd type(entry_t), pointer :: first => null () type(entry_t), pointer :: next => null () class(evt_t), pointer :: evt_powheg => null () contains <> end type entry_t @ %def entry_t @ Output. Write just the configuration, the event is written by a separate routine. The [[verbose]] option is unused, it is required by the interface of the base-object method. <>= procedure :: write_config => entry_write_config <>= subroutine entry_write_config (object, unit, pacified) class(entry_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacified logical :: pacify integer :: u, i u = given_output_unit (unit) pacify = .false.; if (present (pacified)) pacify = pacified write (u, "(3x,A,A,A)") "Process = '", char (object%process_id), "'" write (u, "(3x,A,A,A)") "Library = '", char (object%library), "'" write (u, "(3x,A,A,A)") "Run = '", char (object%run_id), "'" write (u, "(3x,A,L1)") "is valid = ", object%valid if (object%has_integral) then if (pacify) then write (u, "(3x,A," // FMT_15 // ")") "Integral = ", object%integral write (u, "(3x,A," // FMT_15 // ")") "Error = ", object%error write (u, "(3x,A,F9.6)") "Weight =", object%process_weight else write (u, "(3x,A," // FMT_19 // ")") "Integral = ", object%integral write (u, "(3x,A," // FMT_19 // ")") "Error = ", object%error write (u, "(3x,A,F13.10)") "Weight =", object%process_weight end if else write (u, "(3x,A)") "Integral = [undefined]" end if write (u, "(3x,A,I0)") "MCI sets = ", object%n_mci call object%counter%write (u) do i = 1, size (object%mci_sets) write (u, "(A)") write (u, "(1x,A,I0,A)") "MCI set #", i, ":" call object%mci_sets(i)%write (u, pacified) end do if (object%resonant_subprocess_set%is_active ()) then write (u, "(A)") call object%write_resonant_subprocess_data (u) end if if (allocated (object%core_safe)) then do i = 1, size (object%core_safe) write (u, "(1x,A,I0,A)") "Saved process-component core #", i, ":" call object%core_safe(i)%core%write (u) end do end if end subroutine entry_write_config @ %def entry_write_config @ Finalizer. The [[instance]] pointer component of the [[event_t]] base type points to a target which we did explicitly allocate in the [[entry_init]] procedure. Therefore, we finalize and explicitly deallocate it here. Then we call the finalizer of the base type. <>= procedure :: final => entry_final <>= subroutine entry_final (object) class(entry_t), intent(inout) :: object integer :: i if (associated (object%instance)) then do i = 1, object%n_mci call object%instance%final_simulation (i) end do call object%instance%final () deallocate (object%instance) end if call object%event_t%final () end subroutine entry_final @ %def entry_final @ Copy the content of an entry into another one, except for the next-pointer <>= procedure :: copy_entry => entry_copy_entry <>= subroutine entry_copy_entry (entry1, entry2) class(entry_t), intent(in), target :: entry1 type(entry_t), intent(inout), target :: entry2 call entry1%event_t%clone (entry2%event_t) entry2%process_id = entry1%process_id entry2%library = entry1%library entry2%run_id = entry1%run_id entry2%has_integral = entry1%has_integral entry2%integral = entry1%integral entry2%error = entry1%error entry2%process_weight = entry1%process_weight entry2%valid = entry1%valid entry2%counter = entry1%counter entry2%n_in = entry1%n_in entry2%n_mci = entry1%n_mci if (allocated (entry1%mci_sets)) then allocate (entry2%mci_sets (size (entry1%mci_sets))) entry2%mci_sets = entry1%mci_sets end if entry2%mci_selector = entry1%mci_selector if (allocated (entry1%core_safe)) then allocate (entry2%core_safe (size (entry1%core_safe))) entry2%core_safe = entry1%core_safe end if entry2%model => entry1%model entry2%qcd = entry1%qcd end subroutine entry_copy_entry @ %def entry_copy_entry @ Initialization. Search for a process entry and allocate a process instance as an anonymous object, temporarily accessible via the [[process_instance]] pointer. Assign data by looking at the process object and at the environment. If [[n_alt]] is set, we prepare for additional alternate sqme and weight entries. The [[compile]] flag is only false if we don't need the Whizard process at all, just its definition. In that case, we skip process initialization. Otherwise, and if the process object is not found initially: if [[integrate]] is set, attempt an integration pass and try again. Otherwise, just initialize the object. If [[generate]] is set, prepare the MCI objects for generating new events. For pure rescanning, this is not necessary. If [[resonance_history]] is set, we create a separate process library which contains all possible restricted subprocesses with distinct resonance histories. These processes will not be integrated, but their matrix element codes are used for determining probabilities of resonance histories. Note that this can work only if the process method is OMega, and the phase-space method is 'wood'. When done, we assign the [[instance]] and [[process]] pointers of the base type by the [[connect]] method, so we can reference them later. TODO: In case of NLO event generation, copying the configuration from the master process is rather intransparent. For instance, we override the process var list by the global var list. <>= procedure :: init => entry_init <>= subroutine entry_init & (entry, process_id, & use_process, integrate, generate, update_sqme, & support_resonance_history, & local, global, n_alt) class(entry_t), intent(inout), target :: entry type(string_t), intent(in) :: process_id logical, intent(in) :: use_process, integrate, generate, update_sqme logical, intent(in) :: support_resonance_history type(rt_data_t), intent(inout), target :: local type(rt_data_t), intent(inout), optional, target :: global integer, intent(in), optional :: n_alt type(process_t), pointer :: process, master_process type(process_instance_t), pointer :: process_instance type(process_library_t), pointer :: prclib_saved integer :: i logical :: res_include_trivial logical :: combined_integration integer :: selected_mci selected_mci = 0 call msg_debug (D_CORE, "entry_init") call msg_debug (D_CORE, "process_id", process_id) call prepare_process & (master_process, process_id, use_process, integrate, local, global) if (signal_is_pending ()) return if (associated (master_process)) then if (.not. master_process%has_matrix_element ()) then entry%has_integral = .true. entry%process_id = process_id entry%valid = .false. return end if else call entry%basic_init (local%var_list) entry%has_integral = .false. entry%process_id = process_id call entry%import_process_def_characteristics (local%prclib, process_id) entry%valid = .true. return end if call entry%basic_init (local%var_list, n_alt) entry%process_id = process_id if (generate .or. integrate) then entry%run_id = master_process%get_run_id () process => master_process else call local%set_log (var_str ("?rebuild_phase_space"), & .false., is_known = .true.) call local%set_log (var_str ("?check_phs_file"), & .false., is_known = .true.) call local%set_log (var_str ("?rebuild_grids"), & .false., is_known = .true.) entry%run_id = & local%var_list%get_sval (var_str ("$run_id")) if (update_sqme) then call prepare_local_process (process, process_id, local) else process => master_process end if end if call entry%import_process_characteristics (process) allocate (entry%mci_sets (entry%n_mci)) do i = 1, size (entry%mci_sets) call entry%mci_sets(i)%init (i, master_process) end do call entry%import_process_results (master_process) call entry%prepare_expressions (local) if (process%is_nlo_calculation ()) then call process%init_nlo_settings (global%var_list) end if combined_integration = local%get_lval (var_str ("?combined_nlo_integration")) if (.not. combined_integration & .and. local%get_lval (var_str ("?fixed_order_nlo_events"))) & selected_mci = process%extract_active_component_mci () call prepare_process_instance (process_instance, process, local%model, & local = local) if (generate) then if (selected_mci > 0) then call process%prepare_simulation (selected_mci) call process_instance%init_simulation (selected_mci, entry%config%safety_factor, & local%get_lval (var_str ("?keep_failed_events"))) else do i = 1, entry%n_mci call process%prepare_simulation (i) call process_instance%init_simulation (i, entry%config%safety_factor, & local%get_lval (var_str ("?keep_failed_events"))) end do end if end if if (support_resonance_history) then prclib_saved => local%prclib call entry%setup_resonant_subprocesses (local, process) if (entry%has_resonant_subprocess_set) then if (signal_is_pending ()) return call entry%compile_resonant_subprocesses (local) if (signal_is_pending ()) return call entry%prepare_resonant_subprocesses (local, global) if (signal_is_pending ()) return call entry%prepare_resonant_subprocess_instances (local) end if if (signal_is_pending ()) return if (associated (prclib_saved)) call local%update_prclib (prclib_saved) end if call entry%setup_event_transforms (process, local) call dispatch_qcd (entry%qcd, local%get_var_list_ptr (), local%os_data) call entry%connect_qcd () select type (pcm => process_instance%pcm) class is (pcm_instance_nlo_t) select type (config => pcm%config) type is (pcm_nlo_t) if (config%settings%fixed_order_nlo) & call pcm%set_fixed_order_event_mode () end select end select if (present (global)) then call entry%connect (process_instance, local%model, global%process_stack) else call entry%connect (process_instance, local%model, local%process_stack) end if call entry%setup_expressions () entry%model => process%get_model_ptr () entry%valid = .true. end subroutine entry_init @ %def entry_init @ <>= procedure :: set_active_real_components => entry_set_active_real_components <>= subroutine entry_set_active_real_components (entry) class(entry_t), intent(inout) :: entry integer :: i_active_real select type (pcm => entry%instance%pcm) class is (pcm_instance_nlo_t) i_active_real = entry%instance%get_real_of_mci () call msg_debug2 (D_CORE, "i_active_real", i_active_real) if (associated (entry%evt_powheg)) then select type (evt => entry%evt_powheg) type is (evt_shower_t) if (entry%process%get_component_type(i_active_real) == COMP_REAL_FIN) then call msg_debug (D_CORE, "Disabling Powheg matching for ", i_active_real) call evt%disable_powheg_matching () else call msg_debug (D_CORE, "Enabling Powheg matching for ", i_active_real) call evt%enable_powheg_matching () end if class default call msg_fatal ("powheg-evt should be evt_shower_t!") end select end if end select end subroutine entry_set_active_real_components @ %def entry_set_active_real_components @ Part of simulation-entry initialization: set up a process object for local use. <>= subroutine prepare_local_process (process, process_id, local) type(process_t), pointer, intent(inout) :: process type(string_t), intent(in) :: process_id type(rt_data_t), intent(inout), target :: local type(integration_t) :: intg call intg%create_process (process_id) call intg%init_process (local) call intg%setup_process (local, verbose=.false.) process => intg%get_process_ptr () end subroutine prepare_local_process @ %def prepare_local_process @ Part of simulation-entry initialization: set up a process instance matching the selected process object. The model that we can provide as an extra argument can modify particle settings (polarization) in the density matrices that will be constructed. It does not affect parameters. <>= subroutine prepare_process_instance & (process_instance, process, model, local) type(process_instance_t), pointer, intent(inout) :: process_instance type(process_t), intent(inout), target :: process class(model_data_t), intent(in), optional :: model type(rt_data_t), intent(in), optional, target :: local allocate (process_instance) call process_instance%init (process) if (process%is_nlo_calculation ()) then select type (pcm => process_instance%pcm) type is (pcm_instance_nlo_t) select type (config => pcm%config) type is (pcm_nlo_t) if (.not. config%settings%combined_integration) & call pcm%set_radiation_event () end select end select call process%prepare_any_external_code () end if call process_instance%setup_event_data (model) end subroutine prepare_process_instance @ %def prepare_process_instance @ Part of simulation-entry initialization: query the process for basic information. <>= procedure, private :: import_process_characteristics & => entry_import_process_characteristics <>= subroutine entry_import_process_characteristics (entry, process) class(entry_t), intent(inout) :: entry type(process_t), intent(in), target :: process entry%library = process%get_library_name () entry%n_in = process%get_n_in () entry%n_mci = process%get_n_mci () end subroutine entry_import_process_characteristics @ %def entry_import_process_characteristics @ This is the alternative form which applies if there is no process entry, but just a process definition which we take from the provided [[prclib]] definition library. <>= procedure, private :: import_process_def_characteristics & => entry_import_process_def_characteristics <>= subroutine entry_import_process_def_characteristics (entry, prclib, id) class(entry_t), intent(inout) :: entry type(process_library_t), intent(in), target :: prclib type(string_t), intent(in) :: id entry%library = prclib%get_name () entry%n_in = prclib%get_n_in (id) end subroutine entry_import_process_def_characteristics @ %def entry_import_process_def_characteristics @ Part of simulation-entry initialization: query the process for integration results. <>= procedure, private :: import_process_results & => entry_import_process_results <>= subroutine entry_import_process_results (entry, process) class(entry_t), intent(inout) :: entry type(process_t), intent(in), target :: process if (process%has_integral ()) then entry%integral = process%get_integral () entry%error = process%get_error () call entry%set_sigma (entry%integral) entry%has_integral = .true. end if end subroutine entry_import_process_results @ %def entry_import_process_characteristics @ Part of simulation-entry initialization: create expression factory objects and store them. <>= procedure, private :: prepare_expressions & => entry_prepare_expressions <>= subroutine entry_prepare_expressions (entry, local) class(entry_t), intent(inout) :: entry type(rt_data_t), intent(in), target :: local type(eval_tree_factory_t) :: expr_factory call expr_factory%init (local%pn%selection_lexpr) call entry%set_selection (expr_factory) call expr_factory%init (local%pn%reweight_expr) call entry%set_reweight (expr_factory) call expr_factory%init (local%pn%analysis_lexpr) call entry%set_analysis (expr_factory) end subroutine entry_prepare_expressions @ %def entry_prepare_expressions @ Initializes the list of additional NLO entries. The routine gets the information about how many entries to associate from [[region_data]]. <>= procedure :: setup_additional_entries => entry_setup_additional_entries <>= subroutine entry_setup_additional_entries (entry) class(entry_t), intent(inout), target :: entry type(entry_t), pointer :: current_entry integer :: i, n_phs type(evt_nlo_t), pointer :: evt integer :: mode evt => null () select type (pcm => entry%instance%pcm) class is (pcm_instance_nlo_t) select type (config => pcm%config) type is (pcm_nlo_t) n_phs = config%region_data%n_phs end select end select select type (entry) type is (entry_t) current_entry => entry current_entry%first => entry call get_nlo_evt_ptr (current_entry, evt, mode) if (mode > EVT_NLO_SEPARATE_BORNLIKE) then allocate (evt%particle_set_radiated (n_phs + 1)) evt%event_deps%n_phs = n_phs evt%qcd = entry%qcd do i = 1, n_phs allocate (current_entry%next) current_entry%next%first => current_entry%first current_entry => current_entry%next call entry%copy_entry (current_entry) current_entry%i_event = i end do else allocate (evt%particle_set_radiated (1)) end if end select contains subroutine get_nlo_evt_ptr (entry, evt, mode) type(entry_t), intent(in), target :: entry type(evt_nlo_t), intent(out), pointer :: evt integer, intent(out) :: mode class(evt_t), pointer :: current_evt evt => null () current_evt => entry%transform_first do select type (current_evt) type is (evt_nlo_t) evt => current_evt mode = evt%mode exit end select if (associated (current_evt%next)) then current_evt => current_evt%next else call msg_fatal ("evt_nlo not in list of event transforms") end if end do end subroutine get_nlo_evt_ptr end subroutine entry_setup_additional_entries @ %def entry_setup_additional_entries @ <>= procedure :: get_first => entry_get_first <>= function entry_get_first (entry) result (entry_out) class(entry_t), intent(in), target :: entry type(entry_t), pointer :: entry_out entry_out => null () select type (entry) type is (entry_t) if (entry%is_nlo ()) then entry_out => entry%first else entry_out => entry end if end select end function entry_get_first @ %def entry_get_first @ <>= procedure :: get_next => entry_get_next <>= function entry_get_next (entry) result (next_entry) class(entry_t), intent(in) :: entry type(entry_t), pointer :: next_entry next_entry => null () if (associated (entry%next)) then next_entry => entry%next else call msg_fatal ("Get next entry: No next entry") end if end function entry_get_next @ %def entry_get_next @ <>= procedure :: count_nlo_entries => entry_count_nlo_entries <>= function entry_count_nlo_entries (entry) result (n) class(entry_t), intent(in), target :: entry integer :: n type(entry_t), pointer :: current_entry n = 1 if (.not. associated (entry%next)) then return else current_entry => entry%next do n = n + 1 if (.not. associated (current_entry%next)) exit current_entry => current_entry%next end do end if end function entry_count_nlo_entries @ %def entry_count_nlo_entries @ <>= procedure :: reset_nlo_counter => entry_reset_nlo_counter <>= subroutine entry_reset_nlo_counter (entry) class(entry_t), intent(inout) :: entry class(evt_t), pointer :: evt evt => entry%transform_first do select type (evt) type is (evt_nlo_t) evt%i_evaluation = 0 exit end select if (associated (evt%next)) evt => evt%next end do end subroutine entry_reset_nlo_counter @ %def entry_reset_nlo_counter @ <>= procedure :: determine_if_powheg_matching => entry_determine_if_powheg_matching <>= subroutine entry_determine_if_powheg_matching (entry) class(entry_t), intent(inout) :: entry class(evt_t), pointer :: current_transform if (associated (entry%transform_first)) then current_transform => entry%transform_first do select type (current_transform) type is (evt_shower_t) if (current_transform%contains_powheg_matching ()) & entry%evt_powheg => current_transform exit end select if (associated (current_transform%next)) then current_transform => current_transform%next else exit end if end do end if end subroutine entry_determine_if_powheg_matching @ %def entry_determine_if_powheg_matching @ Part of simulation-entry initialization: dispatch event transforms (decay, shower) as requested. If a transform is not applicable or switched off via some variable, it will be skipped. Regarding resonances/decays: these two transforms are currently mutually exclusive. Resonance insertion will not be applied if there is an unstable particle in the game. <>= procedure, private :: setup_event_transforms & => entry_setup_event_transforms <>= subroutine entry_setup_event_transforms (entry, process, local) class(entry_t), intent(inout) :: entry type(process_t), intent(inout), target :: process type(rt_data_t), intent(in), target :: local class(evt_t), pointer :: evt type(var_list_t), pointer :: var_list logical :: enable_isr_handler logical :: enable_epa_handler logical :: enable_fixed_order logical :: enable_shower var_list => local%get_var_list_ptr () enable_isr_handler = local%get_lval (var_str ("?isr_handler")) enable_epa_handler = local%get_lval (var_str ("?epa_handler")) if (enable_isr_handler .or. enable_epa_handler) then call dispatch_evt_isr_epa_handler (evt, local%var_list) if (associated (evt)) call entry%import_transform (evt) end if if (process%contains_unstable (local%model)) then call dispatch_evt_decay (evt, local%var_list) if (associated (evt)) call entry%import_transform (evt) else if (entry%resonant_subprocess_set%is_active ()) then call dispatch_evt_resonance (evt, local%var_list, & entry%resonant_subprocess_set%get_resonance_history_set (), & entry%resonant_subprocess_set%get_libname ()) if (associated (evt)) then call entry%resonant_subprocess_set%connect_transform (evt) call entry%resonant_subprocess_set%set_on_shell_limit & (local%get_rval (var_str ("resonance_on_shell_limit"))) call entry%resonant_subprocess_set%set_on_shell_turnoff & (local%get_rval (var_str ("resonance_on_shell_turnoff"))) call entry%resonant_subprocess_set%set_background_factor & (local%get_rval (var_str ("resonance_background_factor"))) call entry%import_transform (evt) end if end if enable_fixed_order = local%get_lval (var_str ("?fixed_order_nlo_events")) if (enable_fixed_order) then if (local%get_lval (var_str ("?unweighted"))) & call msg_fatal ("NLO Fixed Order events have to be generated with & &?unweighted = false") call dispatch_evt_nlo (evt, local%get_lval (var_str ("?keep_failed_events"))) call entry%import_transform (evt) end if enable_shower = local%get_lval (var_str ("?allow_shower")) .and. & (local%get_lval (var_str ("?ps_isr_active")) & .or. local%get_lval (var_str ("?ps_fsr_active")) & .or. local%get_lval (var_str ("?muli_active")) & .or. local%get_lval (var_str ("?mlm_matching")) & .or. local%get_lval (var_str ("?ckkw_matching")) & .or. local%get_lval (var_str ("?powheg_matching"))) if (enable_shower) then call dispatch_evt_shower (evt, var_list, local%model, & local%fallback_model, local%os_data, local%beam_structure, & process) call entry%import_transform (evt) end if if (local%get_lval (var_str ("?hadronization_active"))) then call dispatch_evt_hadrons (evt, var_list, local%fallback_model) call entry%import_transform (evt) end if end subroutine entry_setup_event_transforms @ %def entry_setup_event_transforms @ Compute weights. The integral in the argument is the sum of integrals for all processes in the sample. After computing the process weights, we repeat the normalization procedure for the process components. <>= procedure :: init_mci_selector => entry_init_mci_selector <>= subroutine entry_init_mci_selector (entry, negative_weights) class(entry_t), intent(inout), target :: entry logical, intent(in), optional :: negative_weights type(entry_t), pointer :: current_entry integer :: i, j, k call msg_debug (D_CORE, "entry_init_mci_selector") if (entry%has_integral) then select type (entry) type is (entry_t) current_entry => entry do j = 1, current_entry%count_nlo_entries () if (j > 1) current_entry => current_entry%get_next () do k = 1, size(current_entry%mci_sets%integral) call msg_debug (D_CORE, "current_entry%mci_sets(k)%integral", & current_entry%mci_sets(k)%integral) end do call current_entry%mci_selector%init & (current_entry%mci_sets%integral, negative_weights) do i = 1, current_entry%n_mci current_entry%mci_sets(i)%weight_mci = & current_entry%mci_selector%get_weight (i) end do end do end select end if end subroutine entry_init_mci_selector @ %def entry_init_mci_selector @ Select a MCI entry, using the embedded random-number generator. <>= procedure :: select_mci => entry_select_mci <>= function entry_select_mci (entry) result (i_mci) class(entry_t), intent(inout) :: entry integer :: i_mci call msg_debug2 (D_CORE, "entry_select_mci") i_mci = entry%process%extract_active_component_mci () if (i_mci == 0) call entry%mci_selector%generate (entry%rng, i_mci) call msg_debug2 (D_CORE, "i_mci", i_mci) end function entry_select_mci @ %def entry_select_mci @ Record an event for this entry, i.e., increment the appropriate counters. <>= procedure :: record => entry_record <>= subroutine entry_record (entry, i_mci, from_file) class(entry_t), intent(inout) :: entry integer, intent(in) :: i_mci logical, intent(in), optional :: from_file real(default) :: weight, excess integer :: n_dropped weight = entry%get_weight_prc () excess = entry%get_excess_prc () n_dropped = entry%get_n_dropped () call entry%counter%record (weight, excess, n_dropped, from_file) if (i_mci > 0) then call entry%mci_sets(i_mci)%counter%record (weight, excess) end if end subroutine entry_record @ %def entry_record @ Update and restore the process core that this entry accesses, when parameters change. If explicit arguments [[model]], [[qcd]], or [[helicity_selection]] are provided, use those. Otherwise use the parameters stored in the process object. <>= procedure :: update_process => entry_update_process procedure :: restore_process => entry_restore_process <>= subroutine entry_update_process & (entry, model, qcd, helicity_selection) class(entry_t), intent(inout) :: entry class(model_data_t), intent(in), optional, target :: model type(qcd_t), intent(in), optional :: qcd type(helicity_selection_t), intent(in), optional :: helicity_selection type(process_t), pointer :: process class(prc_core_t), allocatable :: core integer :: i, n_terms class(model_data_t), pointer :: model_local type(qcd_t) :: qcd_local if (present (model)) then model_local => model else model_local => entry%model end if if (present (qcd)) then qcd_local = qcd else qcd_local = entry%qcd end if process => entry%get_process_ptr () n_terms = process%get_n_terms () allocate (entry%core_safe (n_terms)) do i = 1, n_terms if (process%has_matrix_element (i, is_term_index = .true.)) then call process%extract_core (i, core) call dispatch_core_update (core, & model_local, helicity_selection, qcd_local, & entry%core_safe(i)%core) call process%restore_core (i, core) end if end do end subroutine entry_update_process subroutine entry_restore_process (entry) class(entry_t), intent(inout) :: entry type(process_t), pointer :: process class(prc_core_t), allocatable :: core integer :: i, n_terms process => entry%get_process_ptr () n_terms = process%get_n_terms () do i = 1, n_terms if (process%has_matrix_element (i, is_term_index = .true.)) then call process%extract_core (i, core) call dispatch_core_restore (core, entry%core_safe(i)%core) call process%restore_core (i, core) end if end do deallocate (entry%core_safe) end subroutine entry_restore_process @ %def entry_update_process @ %def entry_restore_process <>= procedure :: connect_qcd => entry_connect_qcd <>= subroutine entry_connect_qcd (entry) class(entry_t), intent(inout), target :: entry class(evt_t), pointer :: evt evt => entry%transform_first do while (associated (evt)) select type (evt) type is (evt_shower_t) evt%qcd = entry%qcd if (allocated (evt%matching)) then evt%matching%qcd = entry%qcd end if end select evt => evt%next end do end subroutine entry_connect_qcd @ %def entry_connect_qcd @ \subsection{Handling resonant subprocesses} Resonant subprocesses are required if we want to determine resonance histories when generating events. The feature is optional, to be switched on by the user. This procedure initializes a new, separate process library that contains copies of the current process, restricted to the relevant resonance histories. (If this library exists already, it is just kept.) The histories can be extracted from the process object. The code has to match the assignments in [[create_resonant_subprocess_library]]. The library may already exist -- in that case, here it will be recovered without recompilation. <>= procedure :: setup_resonant_subprocesses & => entry_setup_resonant_subprocesses <>= subroutine entry_setup_resonant_subprocesses (entry, global, process) class(entry_t), intent(inout) :: entry type(rt_data_t), intent(inout), target :: global type(process_t), intent(in), target :: process type(string_t) :: libname type(resonance_history_set_t) :: res_history_set type(process_library_t), pointer :: lib type(process_component_def_t), pointer :: process_component_def logical :: req_resonant, library_exist integer :: i_component libname = process%get_library_name () lib => global%prclib_stack%get_library_ptr (libname) entry%has_resonant_subprocess_set = lib%req_resonant (process%get_id ()) if (entry%has_resonant_subprocess_set) then libname = get_libname_res (process%get_id ()) call entry%resonant_subprocess_set%init (process%get_n_components ()) call entry%resonant_subprocess_set%create_library & (libname, global, library_exist) do i_component = 1, process%get_n_components () call process%extract_resonance_history_set & (res_history_set, i_component = i_component) call entry%resonant_subprocess_set%fill_resonances & (res_history_set, i_component) if (.not. library_exist) then process_component_def & => process%get_component_def_ptr (i_component) call entry%resonant_subprocess_set%add_to_library & (i_component, & process_component_def%get_prt_spec_in (), & process_component_def%get_prt_spec_out (), & global) end if end do call entry%resonant_subprocess_set%freeze_library (global) end if end subroutine entry_setup_resonant_subprocesses @ %def entry_setup_resonant_subprocesses @ Compile the resonant-subprocesses library. The library is assumed to be the current library in the [[global]] object. This is a simple wrapper. <>= procedure :: compile_resonant_subprocesses & => entry_compile_resonant_subprocesses <>= subroutine entry_compile_resonant_subprocesses (entry, global) class(entry_t), intent(inout) :: entry type(rt_data_t), intent(inout), target :: global call entry%resonant_subprocess_set%compile_library (global) end subroutine entry_compile_resonant_subprocesses @ %def entry_compile_resonant_subprocesses @ Prepare process objects for the resonant-subprocesses library. The process objects are appended to the global process stack. We initialize the processes, such that we can evaluate matrix elements, but we do not need to integrate them. <>= procedure :: prepare_resonant_subprocesses & => entry_prepare_resonant_subprocesses <>= subroutine entry_prepare_resonant_subprocesses (entry, local, global) class(entry_t), intent(inout) :: entry type(rt_data_t), intent(inout), target :: local type(rt_data_t), intent(inout), optional, target :: global call entry%resonant_subprocess_set%prepare_process_objects (local, global) end subroutine entry_prepare_resonant_subprocesses @ %def entry_prepare_resonant_subprocesses @ Prepare process instances. They are linked to their corresponding process objects. Both, process and instance objects, are allocated as anonymous targets inside the [[resonant_subprocess_set]] component. NOTE: those anonymous object are likely forgotten during finalization of the parent [[event_t]] (extended as [[entry_t]]) object. This should be checked! The memory leak is probably harmless as long as the event object is created once per run, not once per event. <>= procedure :: prepare_resonant_subprocess_instances & => entry_prepare_resonant_subprocess_instances <>= subroutine entry_prepare_resonant_subprocess_instances (entry, global) class(entry_t), intent(inout) :: entry type(rt_data_t), intent(in), target :: global call entry%resonant_subprocess_set%prepare_process_instances (global) end subroutine entry_prepare_resonant_subprocess_instances @ %def entry_prepare_resonant_subprocess_instances @ Display the resonant subprocesses. This includes, upon request, the resonance set that defines those subprocess, and a short or long account of the process objects themselves. <>= procedure :: write_resonant_subprocess_data & => entry_write_resonant_subprocess_data <>= subroutine entry_write_resonant_subprocess_data (entry, unit) class(entry_t), intent(in) :: entry integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) call entry%resonant_subprocess_set%write (unit) write (u, "(1x,A,I0)") "Resonant subprocesses refer to & &process component #", 1 end subroutine entry_write_resonant_subprocess_data @ %def entry_write_resonant_subprocess_data @ Display of the master process for the current event, for diagnostics. <>= procedure :: write_process_data => entry_write_process_data <>= subroutine entry_write_process_data & (entry, unit, show_process, show_instance, verbose) class(entry_t), intent(in) :: entry integer, intent(in), optional :: unit logical, intent(in), optional :: show_process logical, intent(in), optional :: show_instance logical, intent(in), optional :: verbose integer :: u, i logical :: s_proc, s_inst, verb type(process_t), pointer :: process type(process_instance_t), pointer :: instance u = given_output_unit (unit) s_proc = .false.; if (present (show_process)) s_proc = show_process s_inst = .false.; if (present (show_instance)) s_inst = show_instance verb = .false.; if (present (verbose)) verb = verbose if (s_proc .or. s_inst) then write (u, "(1x,A,':')") "Process data" if (s_proc) then process => entry%process if (associated (process)) then if (verb) then call write_separator (u, 2) call process%write (.false., u) else call process%show (u, verbose=.false.) end if else write (u, "(3x,A)") "[not associated]" end if end if if (s_inst) then instance => entry%instance if (associated (instance)) then if (verb) then call instance%write (u) else call instance%write_header (u) end if else write (u, "(3x,A)") "Process instance: [not associated]" end if end if end if end subroutine entry_write_process_data @ %def entry_write_process_data @ \subsection{Entries for alternative environment} Entries for alternate environments. [No additional components anymore, so somewhat redundant.] <>= type, extends (entry_t) :: alt_entry_t contains <> end type alt_entry_t @ %def alt_entry_t The alternative entries are there to re-evaluate the event, given momenta, in a different context. Therefore, we allocate a local process object and use this as the reference for the local process instance, when initializing the entry. We temporarily import the [[process]] object into an [[integration_t]] wrapper, to take advantage of the associated methods. The local process object is built in the context of the current environment, here called [[global]]. Then, we initialize the process instance. The [[master_process]] object contains the integration results to which we refer when recalculating an event. Therefore, we use this object instead of the locally built [[process]] when we extract the integration results. The locally built [[process]] object should be finalized when done. It remains accessible via the [[event_t]] base object of [[entry]], which contains pointers to the process and instance. <>= procedure :: init_alt => alt_entry_init <>= subroutine alt_entry_init (entry, process_id, master_process, local) class(alt_entry_t), intent(inout), target :: entry type(string_t), intent(in) :: process_id type(process_t), intent(in), target :: master_process type(rt_data_t), intent(inout), target :: local type(process_t), pointer :: process type(process_instance_t), pointer :: process_instance type(string_t) :: run_id integer :: i call msg_message ("Simulate: initializing alternate process setup ...") run_id = & local%var_list%get_sval (var_str ("$run_id")) call local%set_log (var_str ("?rebuild_phase_space"), & .false., is_known = .true.) call local%set_log (var_str ("?check_phs_file"), & .false., is_known = .true.) call local%set_log (var_str ("?rebuild_grids"), & .false., is_known = .true.) call entry%basic_init (local%var_list) call prepare_local_process (process, process_id, local) entry%process_id = process_id entry%run_id = run_id call entry%import_process_characteristics (process) allocate (entry%mci_sets (entry%n_mci)) do i = 1, size (entry%mci_sets) call entry%mci_sets(i)%init (i, master_process) end do call entry%import_process_results (master_process) call entry%prepare_expressions (local) call prepare_process_instance (process_instance, process, local%model) call entry%setup_event_transforms (process, local) call entry%connect (process_instance, local%model, local%process_stack) call entry%setup_expressions () entry%model => process%get_model_ptr () call msg_message ("... alternate process setup complete.") end subroutine alt_entry_init @ %def alt_entry_init @ Copy the particle set from the master entry to the alternate entry. This is the particle set of the hard process. <>= procedure :: fill_particle_set => entry_fill_particle_set <>= subroutine entry_fill_particle_set (alt_entry, entry) class(alt_entry_t), intent(inout) :: alt_entry class(entry_t), intent(in), target :: entry type(particle_set_t) :: pset call entry%get_hard_particle_set (pset) call alt_entry%set_hard_particle_set (pset) call pset%final () end subroutine entry_fill_particle_set @ %def particle_set_copy_prt @ \subsection{The simulation type} Each simulation object corresponds to an event sample, identified by the [[sample_id]]. The simulation may cover several processes simultaneously. All process-specific data, including the event records, are stored in the [[entry]] subobjects. The [[current]] index indicates which record was selected last. [[version]] is foreseen to contain a tag on the \whizard\ event file version. It can be <>= public :: simulation_t <>= type :: simulation_t private type(rt_data_t), pointer :: local => null () type(string_t) :: sample_id logical :: unweighted = .true. logical :: negative_weights = .false. logical :: support_resonance_history = .false. logical :: respect_selection = .true. integer :: norm_mode = NORM_UNDEFINED logical :: update_sqme = .false. logical :: update_weight = .false. logical :: update_event = .false. logical :: recover_beams = .false. logical :: pacify = .false. integer :: n_max_tries = 10000 integer :: n_prc = 0 integer :: n_alt = 0 logical :: has_integral = .false. logical :: valid = .false. real(default) :: integral = 0 real(default) :: error = 0 integer :: version = 1 character(32) :: md5sum_prc = "" character(32) :: md5sum_cfg = "" character(32), dimension(:), allocatable :: md5sum_alt type(entry_t), dimension(:), allocatable :: entry type(alt_entry_t), dimension(:,:), allocatable :: alt_entry type(selector_t) :: process_selector integer :: n_evt_requested = 0 integer :: event_index_offset = 0 logical :: event_index_set = .false. integer :: event_index = 0 integer :: split_n_evt = 0 integer :: split_n_kbytes = 0 integer :: split_index = 0 type(counter_t) :: counter class(rng_t), allocatable :: rng integer :: i_prc = 0 integer :: i_mci = 0 real(default) :: weight = 0 real(default) :: excess = 0 integer :: n_dropped = 0 contains <> end type simulation_t @ %def simulation_t @ Output. [[write_config]] writes just the configuration. [[write]] as a method of the base type [[event_t]] writes the current event and process instance, depending on options. <>= procedure :: write => simulation_write <>= subroutine simulation_write (object, unit, testflag) class(simulation_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag logical :: pacified integer :: u, i u = given_output_unit (unit) pacified = object%pacify; if (present (testflag)) pacified = testflag call write_separator (u, 2) write (u, "(1x,A,A,A)") "Event sample: '", char (object%sample_id), "'" write (u, "(3x,A,I0)") "Processes = ", object%n_prc if (object%n_alt > 0) then write (u, "(3x,A,I0)") "Alt.wgts = ", object%n_alt end if write (u, "(3x,A,L1)") "Unweighted = ", object%unweighted write (u, "(3x,A,A)") "Event norm = ", & char (event_normalization_string (object%norm_mode)) write (u, "(3x,A,L1)") "Neg. weights = ", object%negative_weights write (u, "(3x,A,L1)") "Res. history = ", object%support_resonance_history write (u, "(3x,A,L1)") "Respect sel. = ", object%respect_selection write (u, "(3x,A,L1)") "Update sqme = ", object%update_sqme write (u, "(3x,A,L1)") "Update wgt = ", object%update_weight write (u, "(3x,A,L1)") "Update event = ", object%update_event write (u, "(3x,A,L1)") "Recov. beams = ", object%recover_beams write (u, "(3x,A,L1)") "Pacify = ", object%pacify write (u, "(3x,A,I0)") "Max. tries = ", object%n_max_tries if (object%has_integral) then if (pacified) then write (u, "(3x,A," // FMT_15 // ")") & "Integral = ", object%integral write (u, "(3x,A," // FMT_15 // ")") & "Error = ", object%error else write (u, "(3x,A," // FMT_19 // ")") & "Integral = ", object%integral write (u, "(3x,A," // FMT_19 // ")") & "Error = ", object%error end if else write (u, "(3x,A)") "Integral = [undefined]" end if write (u, "(3x,A,L1)") "Sim. valid = ", object%valid write (u, "(3x,A,I0)") "Ev.file ver. = ", object%version if (object%md5sum_prc /= "") then write (u, "(3x,A,A,A)") "MD5 sum (proc) = '", object%md5sum_prc, "'" end if if (object%md5sum_cfg /= "") then write (u, "(3x,A,A,A)") "MD5 sum (config) = '", object%md5sum_cfg, "'" end if write (u, "(3x,A,I0)") "Events requested = ", object%n_evt_requested if (object%event_index_offset /= 0) then write (u, "(3x,A,I0)") "Event index offset= ", object%event_index_offset end if if (object%event_index_set) then write (u, "(3x,A,I0)") "Event index = ", object%event_index end if if (object%split_n_evt > 0 .or. object%split_n_kbytes > 0) then write (u, "(3x,A,I0)") "Events per file = ", object%split_n_evt write (u, "(3x,A,I0)") "KBytes per file = ", object%split_n_kbytes write (u, "(3x,A,I0)") "First file index = ", object%split_index end if call object%counter%write (u) call write_separator (u) if (object%i_prc /= 0) then write (u, "(1x,A)") "Current event:" write (u, "(3x,A,I0,A,A)") "Process #", & object%i_prc, ": ", & char (object%entry(object%i_prc)%process_id) write (u, "(3x,A,I0)") "MCI set #", object%i_mci write (u, "(3x,A," // FMT_19 // ")") "Weight = ", object%weight if (.not. vanishes (object%excess)) & write (u, "(3x,A," // FMT_19 // ")") "Excess = ", object%excess write (u, "(3x,A,I0)") "Zero-weight events dropped = ", object%n_dropped else write (u, "(1x,A,I0,A,A)") "Current event: [undefined]" end if call write_separator (u) if (allocated (object%rng)) then call object%rng%write (u) else write (u, "(3x,A)") "Random-number generator: [undefined]" end if if (allocated (object%entry)) then do i = 1, size (object%entry) if (i == 1) then call write_separator (u, 2) else call write_separator (u) end if write (u, "(1x,A,I0,A)") "Process #", i, ":" call object%entry(i)%write_config (u, pacified) end do end if call write_separator (u, 2) end subroutine simulation_write @ %def simulation_write @ Write the current event record. If an explicit index is given, write that event record. We implement writing to [[unit]] (event contents / debugging format) and writing to an [[eio]] event stream (storage). We include a [[testflag]] in order to suppress numerical noise in the testsuite. <>= generic :: write_event => write_event_unit procedure :: write_event_unit => simulation_write_event_unit <>= subroutine simulation_write_event_unit & (object, unit, i_prc, verbose, testflag) class(simulation_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer, intent(in), optional :: i_prc logical, intent(in), optional :: testflag logical :: pacified integer :: current pacified = .false.; if (present(testflag)) pacified = testflag pacified = pacified .or. object%pacify if (present (i_prc)) then current = i_prc else current = object%i_prc end if if (current > 0) then call object%entry(current)%write (unit, verbose = verbose, & testflag = pacified) else call msg_fatal ("Simulation: write event: no process selected") end if end subroutine simulation_write_event_unit @ %def simulation_write_event @ This writes one of the alternate events, if allocated. <>= procedure :: write_alt_event => simulation_write_alt_event <>= subroutine simulation_write_alt_event (object, unit, j_alt, i_prc, & verbose, testflag) class(simulation_t), intent(in) :: object integer, intent(in), optional :: unit integer, intent(in), optional :: j_alt integer, intent(in), optional :: i_prc logical, intent(in), optional :: verbose logical, intent(in), optional :: testflag integer :: i, j if (present (j_alt)) then j = j_alt else j = 1 end if if (present (i_prc)) then i = i_prc else i = object%i_prc end if if (i > 0) then if (j> 0 .and. j <= object%n_alt) then call object%alt_entry(i,j)%write (unit, verbose = verbose, & testflag = testflag) else call msg_fatal ("Simulation: write alternate event: out of range") end if else call msg_fatal ("Simulation: write alternate event: no process selected") end if end subroutine simulation_write_alt_event @ %def simulation_write_alt_event @ This writes the contents of the resonant subprocess set in the current event record. <>= procedure :: write_resonant_subprocess_data & => simulation_write_resonant_subprocess_data <>= subroutine simulation_write_resonant_subprocess_data (object, unit, i_prc) class(simulation_t), intent(in) :: object integer, intent(in), optional :: unit integer, intent(in), optional :: i_prc integer :: i if (present (i_prc)) then i = i_prc else i = object%i_prc end if call object%entry(i)%write_resonant_subprocess_data (unit) end subroutine simulation_write_resonant_subprocess_data @ %def simulation_write_resonant_subprocess_data @ The same for the master process, as an additional debugging aid. <>= procedure :: write_process_data & => simulation_write_process_data <>= subroutine simulation_write_process_data & (object, unit, i_prc, & show_process, show_instance, verbose) class(simulation_t), intent(in) :: object integer, intent(in), optional :: unit integer, intent(in), optional :: i_prc logical, intent(in), optional :: show_process logical, intent(in), optional :: show_instance logical, intent(in), optional :: verbose integer :: i if (present (i_prc)) then i = i_prc else i = object%i_prc end if call object%entry(i)%write_process_data & (unit, show_process, show_instance, verbose) end subroutine simulation_write_process_data @ %def simulation_write_process_data @ Finalizer. <>= procedure :: final => simulation_final <>= subroutine simulation_final (object) class(simulation_t), intent(inout) :: object integer :: i, j if (allocated (object%entry)) then do i = 1, size (object%entry) call object%entry(i)%final () end do end if if (allocated (object%alt_entry)) then do j = 1, size (object%alt_entry, 2) do i = 1, size (object%alt_entry, 1) call object%alt_entry(i,j)%final () end do end do end if if (allocated (object%rng)) call object%rng%final () end subroutine simulation_final @ %def simulation_final @ Initialization. We can deduce all data from the given list of process IDs and the global data set. The process objects are taken from the stack. Once the individual integrals are known, we add them (and the errors), to get the sample integral. If there are alternative environments, we suspend initialization for setting up alternative process objects, then restore the master process and its parameters. The generator or rescanner can then switch rapidly between processes. If [[integrate]] is set, we make sure that all affected processes are integrated before simulation. This is necessary if we want to actually generate events. If [[integrate]] is unset, we don't need the integral because we just rescan existing events. In that case, we just need compiled matrix elements. If [[generate]] is set, we prepare for actually generating events. Otherwise, we may only read and rescan events. <>= procedure :: init => simulation_init <>= subroutine simulation_init (simulation, & process_id, integrate, generate, local, global, alt_env) class(simulation_t), intent(out), target :: simulation type(string_t), dimension(:), intent(in) :: process_id logical, intent(in) :: integrate, generate type(rt_data_t), intent(inout), target :: local type(rt_data_t), intent(inout), optional, target :: global type(rt_data_t), dimension(:), intent(inout), optional, target :: alt_env class(rng_factory_t), allocatable :: rng_factory integer :: next_rng_seed type(string_t) :: norm_string, version_string logical :: use_process integer :: i, j type(string_t) :: sample_suffix <> sample_suffix = "" <> simulation%local => local simulation%sample_id = & local%get_sval (var_str ("$sample")) // sample_suffix simulation%unweighted = & local%get_lval (var_str ("?unweighted")) simulation%negative_weights = & local%get_lval (var_str ("?negative_weights")) simulation%support_resonance_history = & local%get_lval (var_str ("?resonance_history")) simulation%respect_selection = & local%get_lval (var_str ("?sample_select")) version_string = & local%get_sval (var_str ("$event_file_version")) norm_string = & local%get_sval (var_str ("$sample_normalization")) simulation%norm_mode = & event_normalization_mode (norm_string, simulation%unweighted) simulation%pacify = & local%get_lval (var_str ("?sample_pacify")) simulation%event_index_offset = & local%get_ival (var_str ("event_index_offset")) simulation%n_max_tries = & local%get_ival (var_str ("sample_max_tries")) simulation%split_n_evt = & local%get_ival (var_str ("sample_split_n_evt")) simulation%split_n_kbytes = & local%get_ival (var_str ("sample_split_n_kbytes")) simulation%split_index = & local%get_ival (var_str ("sample_split_index")) simulation%update_sqme = & local%get_lval (var_str ("?update_sqme")) simulation%update_weight = & local%get_lval (var_str ("?update_weight")) simulation%update_event = & local%get_lval (var_str ("?update_event")) simulation%recover_beams = & local%get_lval (var_str ("?recover_beams")) simulation%counter%reproduce_xsection = & local%get_lval (var_str ("?check_event_weights_against_xsection")) use_process = & integrate .or. generate & .or. simulation%update_sqme & .or. simulation%update_weight & .or. simulation%update_event & .or. present (alt_env) select case (size (process_id)) case (0) call msg_error ("Simulation: no process selected") case (1) write (msg_buffer, "(A,A,A)") & "Starting simulation for process '", & char (process_id(1)), "'" call msg_message () case default write (msg_buffer, "(A,A,A)") & "Starting simulation for processes '", & char (process_id(1)), "' etc." call msg_message () end select select case (char (version_string)) case ("", "2.2.4") simulation%version = 2 case ("2.2") simulation%version = 1 case default simulation%version = 0 end select if (simulation%version == 0) then call msg_fatal ("Event file format '" & // char (version_string) & // "' is not compatible with this version.") end if simulation%n_prc = size (process_id) allocate (simulation%entry (simulation%n_prc)) if (present (alt_env)) then simulation%n_alt = size (alt_env) do i = 1, simulation%n_prc call simulation%entry(i)%init (process_id(i), & use_process, integrate, generate, & simulation%update_sqme, & simulation%support_resonance_history, & local, global, simulation%n_alt) if (signal_is_pending ()) return end do simulation%valid = any (simulation%entry%valid) if (.not. simulation%valid) then call msg_error ("Simulate: no process has a valid matrix element.") return end if call simulation%update_processes () allocate (simulation%alt_entry (simulation%n_prc, simulation%n_alt)) allocate (simulation%md5sum_alt (simulation%n_alt)) simulation%md5sum_alt = "" do j = 1, simulation%n_alt do i = 1, simulation%n_prc call simulation%alt_entry(i,j)%init_alt (process_id(i), & simulation%entry(i)%get_process_ptr (), alt_env(j)) if (signal_is_pending ()) return end do end do call simulation%restore_processes () else do i = 1, simulation%n_prc call simulation%entry(i)%init & (process_id(i), & use_process, integrate, generate, & simulation%update_sqme, & simulation%support_resonance_history, & local, global) call simulation%entry(i)%determine_if_powheg_matching () if (signal_is_pending ()) return if (simulation%entry(i)%is_nlo ()) & call simulation%entry(i)%setup_additional_entries () end do simulation%valid = any (simulation%entry%valid) if (.not. simulation%valid) then call msg_error ("Simulate: " & // "no process has a valid matrix element.") return end if end if !!! if this becomes conditional, some ref files will need update (seed change) ! if (generate) then call dispatch_rng_factory (rng_factory, local%var_list, next_rng_seed) call update_rng_seed_in_var_list (local%var_list, next_rng_seed) call rng_factory%make (simulation%rng) ! end if if (all (simulation%entry%has_integral)) then simulation%integral = sum (simulation%entry%integral) simulation%error = sqrt (sum (simulation%entry%error ** 2)) simulation%has_integral = .true. if (integrate .and. generate) then do i = 1, simulation%n_prc if (simulation%entry(i)%integral < 0 .and. .not. & simulation%negative_weights) then call msg_fatal ("Integral of process '" // & char (process_id (i)) // "'is negative.") end if end do end if else if (integrate .and. generate) & call msg_error ("Simulation contains undefined integrals.") end if if (simulation%integral > 0 .or. & (simulation%integral < 0 .and. simulation%negative_weights)) then simulation%valid = .true. else if (generate) then call msg_error ("Simulate: " & // "sum of process integrals must be positive; skipping.") simulation%valid = .false. else simulation%valid = .true. end if if (simulation%valid) call simulation%compute_md5sum () end subroutine simulation_init @ %def simulation_init @ <>= integer :: rank, n_size @ <>= call mpi_get_comm_id (n_size, rank) if (n_size > 1) then sample_suffix = var_str ("_") // str (rank) end if @ @ The number of events that we want to simulate is determined by the settings of [[n_events]], [[luminosity]], and [[?unweighted]]. For weighted events, we take [[n_events]] at face value as the number of matrix element calls. For unweighted events, if the process is a decay, [[n_events]] is the number of unweighted events. In these cases, the luminosity setting is ignored. For unweighted events with a scattering process, we calculate the event number that corresponds to the luminosity, given the current value of the integral. We then compare this with [[n_events]] and choose the larger number. <>= procedure :: compute_n_events => simulation_compute_n_events <>= subroutine simulation_compute_n_events (simulation, n_events, var_list) class(simulation_t), intent(in) :: simulation integer, intent(out) :: n_events type(var_list_t) :: var_list real(default) :: lumi, x_events_lumi integer :: n_events_lumi logical :: is_scattering n_events = & var_list%get_ival (var_str ("n_events")) lumi = & var_list%get_rval (var_str ("luminosity")) if (simulation%unweighted) then is_scattering = simulation%entry(1)%n_in == 2 if (is_scattering) then x_events_lumi = abs (simulation%integral * lumi) if (x_events_lumi < huge (n_events)) then n_events_lumi = nint (x_events_lumi) else call msg_message ("Simulation: luminosity too large, & &limiting number of events") n_events_lumi = huge (n_events) end if if (n_events_lumi > n_events) then call msg_message ("Simulation: using n_events as computed from & &luminosity value") n_events = n_events_lumi else write (msg_buffer, "(A,1x,I0)") & "Simulation: requested number of events =", n_events call msg_message () if (.not. vanishes (simulation%integral)) then write (msg_buffer, "(A,1x,ES11.4)") & " corr. to luminosity [fb-1] = ", & n_events / simulation%integral call msg_message () end if end if end if end if end subroutine simulation_compute_n_events @ %def simulation_compute_n_events @ Write the actual efficiency of the simulation run. We get the total number of events stored in the simulation counter and compare this with the total number of calls stored in the event entries. In order not to miscount samples that are partly read from file, use the [[generated]] counter, not the [[total]] counter. <>= procedure :: show_efficiency => simulation_show_efficiency <>= subroutine simulation_show_efficiency (simulation) class(simulation_t), intent(inout) :: simulation integer :: n_events, n_calls real(default) :: eff n_events = simulation%counter%generated n_calls = sum (simulation%entry%get_actual_calls_total ()) if (n_calls > 0) then eff = real (n_events, kind=default) / n_calls write (msg_buffer, "(A,1x,F6.2,1x,A)") & "Events: actual unweighting efficiency =", 100 * eff, "%" call msg_message () end if end subroutine simulation_show_efficiency @ %def simulation_show_efficiency @ <>= procedure :: get_n_nlo_entries => simulation_get_n_nlo_entries <>= function simulation_get_n_nlo_entries (simulation, i_prc) result (n_extra) class(simulation_t), intent(in) :: simulation integer, intent(in) :: i_prc integer :: n_extra n_extra = simulation%entry(i_prc)%count_nlo_entries () end function simulation_get_n_nlo_entries @ %def simulation_get_n_nlo_entries @ Compute the checksum of the process set. We retrieve the MD5 sums of all processes. This depends only on the process definitions, while parameters are not considered. The configuration checksum is retrieved from the MCI records in the process objects and furthermore includes beams, parameters, integration results, etc., so matching the latter should guarantee identical physics. <>= procedure :: compute_md5sum => simulation_compute_md5sum <>= subroutine simulation_compute_md5sum (simulation) class(simulation_t), intent(inout) :: simulation type(process_t), pointer :: process type(string_t) :: buffer integer :: j, i, n_mci, i_mci, n_component, i_component if (simulation%md5sum_prc == "") then buffer = "" do i = 1, simulation%n_prc if (.not. simulation%entry(i)%valid) cycle process => simulation%entry(i)%get_process_ptr () if (associated (process)) then n_component = process%get_n_components () do i_component = 1, n_component if (process%has_matrix_element (i_component)) then buffer = buffer // process%get_md5sum_prc (i_component) end if end do end if end do simulation%md5sum_prc = md5sum (char (buffer)) end if if (simulation%md5sum_cfg == "") then buffer = "" do i = 1, simulation%n_prc if (.not. simulation%entry(i)%valid) cycle process => simulation%entry(i)%get_process_ptr () if (associated (process)) then n_mci = process%get_n_mci () do i_mci = 1, n_mci buffer = buffer // process%get_md5sum_mci (i_mci) end do end if end do simulation%md5sum_cfg = md5sum (char (buffer)) end if do j = 1, simulation%n_alt if (simulation%md5sum_alt(j) == "") then buffer = "" do i = 1, simulation%n_prc process => simulation%alt_entry(i,j)%get_process_ptr () if (associated (process)) then buffer = buffer // process%get_md5sum_cfg () end if end do simulation%md5sum_alt(j) = md5sum (char (buffer)) end if end do end subroutine simulation_compute_md5sum @ %def simulation_compute_md5sum @ Initialize the process selector, using the entry integrals as process weights. <>= procedure :: init_process_selector => simulation_init_process_selector <>= subroutine simulation_init_process_selector (simulation) class(simulation_t), intent(inout) :: simulation integer :: i if (simulation%has_integral) then call simulation%process_selector%init (simulation%entry%integral, & negative_weights = simulation%negative_weights) do i = 1, simulation%n_prc associate (entry => simulation%entry(i)) if (.not. entry%valid) then call msg_warning ("Process '" // char (entry%process_id) // & "': matrix element vanishes, no events can be generated.") cycle end if call entry%init_mci_selector (simulation%negative_weights) entry%process_weight = simulation%process_selector%get_weight (i) end associate end do end if end subroutine simulation_init_process_selector @ %def simulation_init_process_selector @ Select a process, using the random-number generator. <>= procedure :: select_prc => simulation_select_prc <>= function simulation_select_prc (simulation) result (i_prc) class(simulation_t), intent(inout) :: simulation integer :: i_prc call simulation%process_selector%generate (simulation%rng, i_prc) end function simulation_select_prc @ %def simulation_select_prc @ Select a MCI set for the selected process. <>= procedure :: select_mci => simulation_select_mci <>= function simulation_select_mci (simulation) result (i_mci) class(simulation_t), intent(inout) :: simulation integer :: i_mci i_mci = 0 if (simulation%i_prc /= 0) then i_mci = simulation%entry(simulation%i_prc)%select_mci () end if end function simulation_select_mci @ %def simulation_select_mci @ Generate a predefined number of events. First select a process and a component set, then generate an event for that process and factorize the quantum state. The pair of random numbers can be used for factorization. When generating events, we drop all configurations where the event is marked as incomplete. This happens if the event fails cuts. In fact, such events are dropped already by the sampler if unweighting is in effect, so this can happen only for weighted events. By setting a limit given by [[sample_max_tries]] (user parameter), we can avoid an endless loop. NB: When reading from file, event transforms can't be applied because the process instance will not be complete. This should be fixed. <>= procedure :: generate => simulation_generate <>= subroutine simulation_generate (simulation, n, es_array) class(simulation_t), intent(inout), target :: simulation integer, intent(in) :: n type(event_stream_array_t), intent(inout), optional :: es_array type(string_t) :: str1, str2, str3 logical :: generate_new, passed integer :: i, j, k type(entry_t), pointer :: current_entry integer :: n_events <> simulation%n_evt_requested = n n_events = n * simulation%get_n_nlo_entries (1) call simulation%entry%set_n (n) if (simulation%n_alt > 0) call simulation%alt_entry%set_n (n) str1 = "Events: generating" if (present (es_array)) then if (es_array%has_input ()) str1 = "Events: reading" end if if (simulation%entry(1)%config%unweighted) then str2 = "unweighted" else str2 = "weighted" end if if (simulation%entry(1)%config%factorization_mode == & FM_IGNORE_HELICITY) then str3 = ", unpolarized" else str3 = ", polarized" end if if (n_events == n) then write (msg_buffer, "(A,1x,I0,1x,A,1x,A)") char (str1), n, & char (str2) // char(str3), "events ..." else write (msg_buffer, "(A,1x,I0,1x,A,1x,A)") char (str1), n_events, & char (str2) // char(str3), "NLO events ..." end if call msg_message () write (msg_buffer, "(A,1x,A)") "Events: event normalization mode", & char (event_normalization_string (simulation%norm_mode)) call msg_message () call simulation%init_event_index () <> do i = start_it, end_it call simulation%increment_event_index () if (present (es_array)) then call simulation%read_event (es_array, .true., generate_new) else generate_new = .true. end if if (generate_new) then simulation%i_prc = simulation%select_prc () simulation%i_mci = simulation%select_mci () associate (entry => simulation%entry(simulation%i_prc)) entry%instance%i_mci = simulation%i_mci call entry%set_active_real_components () current_entry => entry%get_first () do k = 1, current_entry%count_nlo_entries () if (k > 1) then current_entry => current_entry%get_next () current_entry%particle_set => current_entry%first%particle_set current_entry%particle_set_is_valid & = current_entry%first%particle_set_is_valid end if do j = 1, simulation%n_max_tries if (.not. current_entry%valid) call msg_warning & ("Process '" // char (current_entry%process_id) // "': " // & "matrix element vanishes, no events can be generated.") call current_entry%generate (simulation%i_mci, i_nlo = k) if (signal_is_pending ()) return call simulation%counter%record_mean_and_variance & (current_entry%weight_prc, k) if (current_entry%has_valid_particle_set ()) exit end do end do if (entry%is_nlo ()) call entry%reset_nlo_counter () if (.not. entry%has_valid_particle_set ()) then write (msg_buffer, "(A,I0,A)") "Simulation: failed to & &generate valid event after ", & simulation%n_max_tries, " tries (sample_max_tries)" call msg_fatal () end if current_entry => entry%get_first () do k = 1, current_entry%count_nlo_entries () if (k > 1) current_entry => current_entry%get_next () call current_entry%set_index (simulation%get_event_index ()) call current_entry%evaluate_expressions () end do if (signal_is_pending ()) return simulation%n_dropped = entry%get_n_dropped () if (entry%passed_selection ()) then simulation%weight = entry%get_weight_ref () simulation%excess = entry%get_excess_prc () end if call simulation%counter%record & (simulation%weight, simulation%excess, simulation%n_dropped) call entry%record (simulation%i_mci) end associate else associate (entry => simulation%entry(simulation%i_prc)) call simulation%set_event_index (entry%get_index ()) call entry%accept_sqme_ref () call entry%accept_weight_ref () call entry%check () call entry%evaluate_expressions () if (signal_is_pending ()) return simulation%n_dropped = entry%get_n_dropped () if (entry%passed_selection ()) then simulation%weight = entry%get_weight_ref () simulation%excess = entry%get_excess_prc () end if call simulation%counter%record & (simulation%weight, simulation%excess, simulation%n_dropped, from_file=.true.) call entry%record (simulation%i_mci, from_file=.true.) end associate end if call simulation%calculate_alt_entries () if (signal_is_pending ()) return if (simulation%pacify) call pacify (simulation) if (simulation%respect_selection) then passed = simulation%entry(simulation%i_prc)%passed_selection () else passed = .true. end if if (present (es_array)) then call simulation%write_event (es_array, passed) end if end do <> call msg_message (" ... event sample complete.") if (simulation%unweighted) call simulation%show_efficiency () call simulation%counter%show_excess () call simulation%counter%show_dropped () call simulation%counter%show_mean_and_variance () end subroutine simulation_generate @ %def simulation_generate @ <>= integer :: start_it, end_it @ <>= start_it = 1 end_it = n @ <>= @ <>= integer :: n_size, rank integer :: worker_n_events, root_n_events <>= call mpi_get_comm_id (n_size, rank) if (n_size > 1) then start_it = start_it + nint (rank * (real (n) / n_size)) end_it = min (nint ((rank + 1) * (real (n) / n_size)), n) write (msg_buffer, "(A,I0,A,I0,A)") & & "MPI: generate events [", start_it, ":", end_it, "]" call msg_message () do i = 1, rank + 1 select type (rng => simulation%rng) type is (rng_stream_t) call rng%next_substream () end select end do end if @ <>= call MPI_Barrier (MPI_COMM_WORLD) if (n_size > 1) then worker_n_events = end_it - start_it + 1 call MPI_Reduce (worker_n_events, root_n_events, 1, MPI_INTEGER, MPI_SUM,& & 0, MPI_COMM_WORLD) if (rank == 0) then write (msg_buffer, "(A,I0)") "MPI: Number of generated events in world = ", root_n_events call msg_message () end if end if @ @ Compute the event matrix element and weight for all alternative environments, given the current event and selected process. We first copy the particle set, then temporarily update the process core with local parameters, recalculate everything, and restore the process core. The event weight is obtained by rescaling the original event weight with the ratio of the new and old [[sqme]] values. (In particular, if the old value was zero, the weight will stay zero.) Note: this may turn out to be inefficient because we always replace all parameters and recalculate everything, once for each event and environment. However, a more fine-grained control requires more code. In any case, while we may keep multiple process cores (which stay constant for a simulation run), we still have to update the external matrix element parameters event by event. The matrix element ``object'' is present only once. <>= procedure :: calculate_alt_entries => simulation_calculate_alt_entries <>= subroutine simulation_calculate_alt_entries (simulation) class(simulation_t), intent(inout) :: simulation real(default) :: factor real(default), dimension(:), allocatable :: sqme_alt, weight_alt integer :: n_alt, i, j i = simulation%i_prc n_alt = simulation%n_alt if (n_alt == 0) return allocate (sqme_alt (n_alt), weight_alt (n_alt)) associate (entry => simulation%entry(i)) do j = 1, n_alt if (signal_is_pending ()) return factor = entry%get_kinematical_weight () associate (alt_entry => simulation%alt_entry(i,j)) call alt_entry%update_process () call alt_entry%select & (entry%get_i_mci (), entry%get_i_term (), entry%get_channel ()) call alt_entry%fill_particle_set (entry) call alt_entry%recalculate & (update_sqme = .true., weight_factor = factor) if (signal_is_pending ()) return call alt_entry%accept_sqme_prc () call alt_entry%update_normalization () call alt_entry%accept_weight_prc () call alt_entry%check () call alt_entry%set_index (simulation%get_event_index ()) call alt_entry%evaluate_expressions () if (signal_is_pending ()) return call alt_entry%restore_process () sqme_alt(j) = alt_entry%get_sqme_ref () if (alt_entry%passed_selection ()) then weight_alt(j) = alt_entry%get_weight_ref () end if end associate end do call entry%set (sqme_alt = sqme_alt, weight_alt = weight_alt) call entry%check () call entry%store_alt_values () end associate end subroutine simulation_calculate_alt_entries @ %def simulation_calculate_alt_entries @ Rescan an undefined number of events. If [[update_event]] or [[update_sqme]] is set, we have to recalculate the event, starting from the particle set. If the latter is set, this includes the squared matrix element (i.e., the amplitude is evaluated). Otherwise, only kinematics and observables derived from it are recovered. If any of the update flags is set, we will come up with separate [[sqme_prc]] and [[weight_prc]] values. (The latter is only distinct if [[update_weight]] is set.) Otherwise, we accept the reference values. <>= procedure :: rescan => simulation_rescan <>= subroutine simulation_rescan (simulation, n, es_array, global) class(simulation_t), intent(inout) :: simulation integer, intent(in) :: n type(event_stream_array_t), intent(inout) :: es_array type(rt_data_t), intent(inout) :: global type(qcd_t) :: qcd type(string_t) :: str1, str2, str3 logical :: complete str1 = "Rescanning" if (simulation%entry(1)%config%unweighted) then str2 = "unweighted" else str2 = "weighted" end if simulation%n_evt_requested = n call simulation%entry%set_n (n) if (simulation%update_sqme .or. simulation%update_weight) then call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data) call simulation%update_processes & (global%model, qcd, global%get_helicity_selection ()) str3 = "(process parameters updated) " else str3 = "" end if write (msg_buffer, "(A,1x,A,1x,A,A,A)") char (str1), char (str2), & "events ", char (str3), "..." call msg_message () call simulation%init_event_index () do call simulation%increment_event_index () call simulation%read_event (es_array, .false., complete) if (complete) exit if (simulation%update_event & .or. simulation%update_sqme & .or. simulation%update_weight) then call simulation%recalculate () if (signal_is_pending ()) return associate (entry => simulation%entry(simulation%i_prc)) call entry%update_normalization () if (simulation%update_event) then call entry%evaluate_transforms () end if call entry%check () call entry%evaluate_expressions () if (signal_is_pending ()) return simulation%n_dropped = entry%get_n_dropped () simulation%weight = entry%get_weight_prc () call simulation%counter%record & (simulation%weight, n_dropped=simulation%n_dropped, from_file=.true.) call entry%record (simulation%i_mci, from_file=.true.) end associate else associate (entry => simulation%entry(simulation%i_prc)) call entry%accept_sqme_ref () call entry%accept_weight_ref () call entry%check () call entry%evaluate_expressions () if (signal_is_pending ()) return simulation%n_dropped = entry%get_n_dropped () simulation%weight = entry%get_weight_ref () call simulation%counter%record & (simulation%weight, n_dropped=simulation%n_dropped, from_file=.true.) call entry%record (simulation%i_mci, from_file=.true.) end associate end if call simulation%calculate_alt_entries () if (signal_is_pending ()) return call simulation%write_event (es_array) end do call simulation%counter%show_dropped () if (simulation%update_sqme .or. simulation%update_weight) then call simulation%restore_processes () end if end subroutine simulation_rescan @ %def simulation_rescan @ Here we handle the event index that is kept in the simulation record. The event index is valid for the current sample. When generating or reading events, we initialize the index with the offset that the user provides (if any) and increment it for each event that is generated or read from file. The event index is stored in the event-entry that is current for the event. If an event on file comes with its own index, that index overwrites the predefined one and also resets the index within the simulation record. The event index is not connected to the [[counter]] object. The counter is supposed to collect statistical information. The event index is a user-level object that is visible in event records and analysis expressions. <>= procedure :: init_event_index => simulation_init_event_index procedure :: increment_event_index => simulation_increment_event_index procedure :: set_event_index => simulation_set_event_index procedure :: get_event_index => simulation_get_event_index <>= subroutine simulation_init_event_index (simulation) class(simulation_t), intent(inout) :: simulation call simulation%set_event_index (simulation%event_index_offset) end subroutine simulation_init_event_index subroutine simulation_increment_event_index (simulation) class(simulation_t), intent(inout) :: simulation if (simulation%event_index_set) then simulation%event_index = simulation%event_index + 1 end if end subroutine simulation_increment_event_index subroutine simulation_set_event_index (simulation, i) class(simulation_t), intent(inout) :: simulation integer, intent(in) :: i simulation%event_index = i simulation%event_index_set = .true. end subroutine simulation_set_event_index function simulation_get_event_index (simulation) result (i) class(simulation_t), intent(in) :: simulation integer :: i if (simulation%event_index_set) then i = simulation%event_index else i = 0 end if end function simulation_get_event_index @ %def simulation_init_event_index @ %def simulation_increment_event_index @ %def simulation_set_event_index @ %def simulation_get_event_index @ @ These routines take care of temporary parameter redefinitions that we want to take effect while recalculating the matrix elements. We extract the core(s) of the processes that we are simulating, apply the changes, and make sure that the changes are actually used. This is the duty of [[dispatch_core_update]]. When done, we restore the original versions using [[dispatch_core_restore]]. <>= procedure :: update_processes => simulation_update_processes procedure :: restore_processes => simulation_restore_processes <>= subroutine simulation_update_processes (simulation, & model, qcd, helicity_selection) class(simulation_t), intent(inout) :: simulation class(model_data_t), intent(in), optional, target :: model type(qcd_t), intent(in), optional :: qcd type(helicity_selection_t), intent(in), optional :: helicity_selection integer :: i do i = 1, simulation%n_prc call simulation%entry(i)%update_process & (model, qcd, helicity_selection) end do end subroutine simulation_update_processes subroutine simulation_restore_processes (simulation) class(simulation_t), intent(inout) :: simulation integer :: i do i = 1, simulation%n_prc call simulation%entry(i)%restore_process () end do end subroutine simulation_restore_processes @ %def simulation_update_processes @ %def simulation_restore_processes @ \subsection{Event Stream I/O} Write an event to a generic [[eio]] event stream. The process index must be selected, or the current index must be available. <>= generic :: write_event => write_event_eio procedure :: write_event_eio => simulation_write_event_eio <>= subroutine simulation_write_event_eio (object, eio, i_prc) class(simulation_t), intent(in) :: object class(eio_t), intent(inout) :: eio integer, intent(in), optional :: i_prc logical :: increased integer :: current if (present (i_prc)) then current = i_prc else current = object%i_prc end if if (current > 0) then if (object%split_n_evt > 0 .and. object%counter%total > 1) then if (mod (object%counter%total, object%split_n_evt) == 1) then call eio%split_out () end if else if (object%split_n_kbytes > 0) then call eio%update_split_count (increased) if (increased) call eio%split_out () end if call eio%output (object%entry(current)%event_t, current, pacify = object%pacify) else call msg_fatal ("Simulation: write event: no process selected") end if end subroutine simulation_write_event_eio @ %def simulation_write_event @ Read an event from a generic [[eio]] event stream. The event stream element must specify the process within the sample ([[i_prc]]), the MC group for this process ([[i_mci]]), the selected term ([[i_term]]), the selected MC integration [[channel]], and the particle set of the event. We may encounter EOF, which we indicate by storing 0 for the process index [[i_prc]]. An I/O error will be reported, and we also abort reading. <>= generic :: read_event => read_event_eio procedure :: read_event_eio => simulation_read_event_eio <>= subroutine simulation_read_event_eio (object, eio) class(simulation_t), intent(inout) :: object class(eio_t), intent(inout) :: eio integer :: iostat, current call eio%input_i_prc (current, iostat) select case (iostat) case (0) object%i_prc = current call eio%input_event (object%entry(current)%event_t, iostat) end select select case (iostat) case (:-1) object%i_prc = 0 object%i_mci = 0 case (1:) call msg_error ("Reading events: I/O error, aborting read") object%i_prc = 0 object%i_mci = 0 case default object%i_mci = object%entry(current)%get_i_mci () end select end subroutine simulation_read_event_eio @ %def simulation_read_event @ \subsection{Event Stream Array} Write an event using an array of event I/O streams. The process index must be selected, or the current index must be available. <>= generic :: write_event => write_event_es_array procedure :: write_event_es_array => simulation_write_event_es_array <>= subroutine simulation_write_event_es_array (object, es_array, passed) class(simulation_t), intent(in), target :: object class(event_stream_array_t), intent(inout) :: es_array logical, intent(in), optional :: passed integer :: i_prc, event_index integer :: i type(entry_t), pointer :: current_entry i_prc = object%i_prc if (i_prc > 0) then event_index = object%counter%total current_entry => object%entry(i_prc)%get_first () do i = 1, current_entry%count_nlo_entries () if (i > 1) current_entry => current_entry%get_next () call es_array%output (current_entry%event_t, i_prc, & event_index, passed = passed, pacify = object%pacify) end do else call msg_fatal ("Simulation: write event: no process selected") end if end subroutine simulation_write_event_es_array @ %def simulation_write_event @ Read an event using an array of event I/O streams. Reading is successful if there is an input stream within the array, and if a valid event can be read from that stream. If there is a stream, but EOF is passed when reading the first item, we switch the channel to output and return failure but no error message, such that new events can be appended to that stream. <>= generic :: read_event => read_event_es_array procedure :: read_event_es_array => simulation_read_event_es_array <>= subroutine simulation_read_event_es_array (object, es_array, enable_switch, & fail) class(simulation_t), intent(inout), target :: object class(event_stream_array_t), intent(inout), target :: es_array logical, intent(in) :: enable_switch logical, intent(out) :: fail integer :: iostat, i_prc type(entry_t), pointer :: current_entry => null () integer :: i if (es_array%has_input ()) then fail = .false. call es_array%input_i_prc (i_prc, iostat) select case (iostat) case (0) object%i_prc = i_prc current_entry => object%entry(i_prc) do i = 1, current_entry%count_nlo_entries () if (i > 1) then call es_array%skip_eio_entry (iostat) current_entry => current_entry%get_next () end if call current_entry%set_index (object%get_event_index ()) call es_array%input_event (current_entry%event_t, iostat) end do case (:-1) write (msg_buffer, "(A,1x,I0,1x,A)") & "... event file terminates after", & object%counter%read, "events." call msg_message () if (enable_switch) then call es_array%switch_inout () write (msg_buffer, "(A,1x,I0,1x,A)") & "Generating remaining ", & object%n_evt_requested - object%counter%read, "events ..." call msg_message () end if fail = .true. return end select select case (iostat) case (0) object%i_mci = object%entry(i_prc)%get_i_mci () case default write (msg_buffer, "(A,1x,I0,1x,A)") & "Reading events: I/O error, aborting read after", & object%counter%read, "events." call msg_error () object%i_prc = 0 object%i_mci = 0 fail = .true. end select else fail = .true. end if end subroutine simulation_read_event_es_array @ %def simulation_read_event @ \subsection{Recover event} Recalculate the process instance contents, given an event with known particle set. The indices for MC, term, and channel must be already set. The [[recalculate]] method of the selected entry will import the result into [[sqme_prc]] and [[weight_prc]]. If [[recover_phs]] is set (and false), do not attempt any phase-space calculation. Useful if we need only matrix elements (esp. testing); this flag is not stored in the simulation record. <>= procedure :: recalculate => simulation_recalculate <>= subroutine simulation_recalculate (simulation, recover_phs) class(simulation_t), intent(inout) :: simulation logical, intent(in), optional :: recover_phs integer :: i_prc i_prc = simulation%i_prc associate (entry => simulation%entry(i_prc)) if (simulation%update_weight) then call entry%recalculate & (update_sqme = simulation%update_sqme, & recover_beams = simulation%recover_beams, & recover_phs = recover_phs, & weight_factor = entry%get_kinematical_weight ()) else call entry%recalculate & (update_sqme = simulation%update_sqme, & recover_beams = simulation%recover_beams, & recover_phs = recover_phs) end if end associate end subroutine simulation_recalculate @ %def simulation_recalculate @ \subsection{Extract contents} Return the MD5 sum that summarizes configuration and integration (but not the event file). Used for initializing the event streams. <>= procedure :: get_md5sum_prc => simulation_get_md5sum_prc procedure :: get_md5sum_cfg => simulation_get_md5sum_cfg procedure :: get_md5sum_alt => simulation_get_md5sum_alt <>= function simulation_get_md5sum_prc (simulation) result (md5sum) class(simulation_t), intent(in) :: simulation character(32) :: md5sum md5sum = simulation%md5sum_prc end function simulation_get_md5sum_prc function simulation_get_md5sum_cfg (simulation) result (md5sum) class(simulation_t), intent(in) :: simulation character(32) :: md5sum md5sum = simulation%md5sum_cfg end function simulation_get_md5sum_cfg function simulation_get_md5sum_alt (simulation, i) result (md5sum) class(simulation_t), intent(in) :: simulation integer, intent(in) :: i character(32) :: md5sum md5sum = simulation%md5sum_alt(i) end function simulation_get_md5sum_alt @ %def simulation_get_md5sum_prc @ %def simulation_get_md5sum_cfg @ Return data that may be useful for writing event files. Usually we can refer to a previously integrated process, for which we can fetch a process pointer. Occasionally, we don't have this because we're just rescanning an externally generated file without calculation. For that situation, we generate our local beam data object using the current enviroment, or, in simple cases, just fetch the necessary data from the process definition and environment. <>= procedure :: get_data => simulation_get_data <>= function simulation_get_data (simulation, alt) result (sdata) class(simulation_t), intent(in) :: simulation logical, intent(in), optional :: alt type(event_sample_data_t) :: sdata type(process_t), pointer :: process type(beam_data_t), pointer :: beam_data type(beam_structure_t), pointer :: beam_structure type(flavor_t), dimension(:), allocatable :: flv integer :: n, i logical :: enable_alt, construct_beam_data real(default) :: sqrts class(model_data_t), pointer :: model logical :: decay_rest_frame type(string_t) :: process_id enable_alt = .true.; if (present (alt)) enable_alt = alt call msg_debug (D_CORE, "simulation_get_data") call msg_debug (D_CORE, "alternative setup", enable_alt) if (enable_alt) then call sdata%init (simulation%n_prc, simulation%n_alt) do i = 1, simulation%n_alt sdata%md5sum_alt(i) = simulation%get_md5sum_alt (i) end do else call sdata%init (simulation%n_prc) end if sdata%unweighted = simulation%unweighted sdata%negative_weights = simulation%negative_weights sdata%norm_mode = simulation%norm_mode process => simulation%entry(1)%get_process_ptr () if (associated (process)) then beam_data => process%get_beam_data_ptr () construct_beam_data = .false. else n = simulation%entry(1)%n_in sqrts = simulation%local%get_sqrts () beam_structure => simulation%local%beam_structure call beam_structure%check_against_n_in (n, construct_beam_data) if (construct_beam_data) then allocate (beam_data) model => simulation%local%model decay_rest_frame = & simulation%local%get_lval (var_str ("?decay_rest_frame")) call beam_data%init_structure (beam_structure, & sqrts, model, decay_rest_frame) else beam_data => null () end if end if if (associated (beam_data)) then n = beam_data%get_n_in () sdata%n_beam = n allocate (flv (n)) flv = beam_data%get_flavor () sdata%pdg_beam(:n) = flv%get_pdg () sdata%energy_beam(:n) = beam_data%get_energy () if (construct_beam_data) deallocate (beam_data) else n = simulation%entry(1)%n_in sdata%n_beam = n process_id = simulation%entry(1)%process_id call simulation%local%prclib%get_pdg_in_1 & (process_id, sdata%pdg_beam(:n)) sdata%energy_beam(:n) = sqrts / n end if do i = 1, simulation%n_prc if (.not. simulation%entry(i)%valid) cycle process => simulation%entry(i)%get_process_ptr () if (associated (process)) then sdata%proc_num_id(i) = process%get_num_id () else process_id = simulation%entry(i)%process_id sdata%proc_num_id(i) = simulation%local%prclib%get_num_id (process_id) end if if (sdata%proc_num_id(i) == 0) sdata%proc_num_id(i) = i if (simulation%entry(i)%has_integral) then sdata%cross_section(i) = simulation%entry(i)%integral sdata%error(i) = simulation%entry(i)%error end if end do sdata%total_cross_section = sum (sdata%cross_section) sdata%md5sum_prc = simulation%get_md5sum_prc () sdata%md5sum_cfg = simulation%get_md5sum_cfg () if (simulation%split_n_evt > 0 .or. simulation%split_n_kbytes > 0) then sdata%split_n_evt = simulation%split_n_evt sdata%split_n_kbytes = simulation%split_n_kbytes sdata%split_index = simulation%split_index end if end function simulation_get_data @ %def simulation_get_data @ Return a default name for the current event sample. This is the process ID of the first process. <>= procedure :: get_default_sample_name => simulation_get_default_sample_name <>= function simulation_get_default_sample_name (simulation) result (sample) class(simulation_t), intent(in) :: simulation type(string_t) :: sample type(process_t), pointer :: process sample = "whizard" if (simulation%n_prc > 0) then process => simulation%entry(1)%get_process_ptr () if (associated (process)) then sample = process%get_id () end if end if end function simulation_get_default_sample_name @ %def simulation_get_default_sample_name @ <>= procedure :: is_valid => simulation_is_valid <>= function simulation_is_valid (simulation) result (valid) class(simulation_t), intent(inout) :: simulation logical :: valid valid = simulation%valid end function simulation_is_valid @ %def simulation_is_valid @ Return the hard-interaction particle set for event entry [[i_prc]]. <>= procedure :: get_hard_particle_set => simulation_get_hard_particle_set <>= function simulation_get_hard_particle_set (simulation, i_prc) result (pset) class(simulation_t), intent(in) :: simulation integer, intent(in) :: i_prc type(particle_set_t) :: pset call simulation%entry(i_prc)%get_hard_particle_set (pset) end function simulation_get_hard_particle_set @ %def simulation_get_hard_particle_set @ \subsection{Auxiliary} Call pacify: eliminate numerical noise. <>= public :: pacify <>= interface pacify module procedure pacify_simulation end interface <>= subroutine pacify_simulation (simulation) class(simulation_t), intent(inout) :: simulation integer :: i, j i = simulation%i_prc if (i > 0) then call pacify (simulation%entry(i)) do j = 1, simulation%n_alt call pacify (simulation%alt_entry(i,j)) end do end if end subroutine pacify_simulation @ %def pacify_simulation @ Manually evaluate expressions for the currently selected process. This is used only in the unit tests. <>= procedure :: evaluate_expressions => simulation_evaluate_expressions <>= subroutine simulation_evaluate_expressions (simulation) class(simulation_t), intent(inout) :: simulation call simulation%entry(simulation%i_prc)%evaluate_expressions () end subroutine simulation_evaluate_expressions @ %def simulation_evaluate_expressions @ Manually evaluate event transforms for the currently selected process. This is used only in the unit tests. <>= procedure :: evaluate_transforms => simulation_evaluate_transforms <>= subroutine simulation_evaluate_transforms (simulation) class(simulation_t), intent(inout) :: simulation associate (entry => simulation%entry(simulation%i_prc)) call entry%evaluate_transforms () end associate end subroutine simulation_evaluate_transforms @ %def simulation_evaluate_transforms @ \subsection{Unit tests} Test module, followed by the stand-alone unit-test procedures. <<[[simulations_ut.f90]]>>= <> module simulations_ut use unit_tests use simulations_uti <> <> contains <> end module simulations_ut @ %def simulations_ut @ <<[[simulations_uti.f90]]>>= <> module simulations_uti <> use kinds, only: i64 <> use io_units use format_defs, only: FMT_10, FMT_12 use ifiles use lexers use parser use lorentz use flavors use interactions, only: reset_interaction_counter use process_libraries, only: process_library_t use prclib_stacks use phs_forests use event_base, only: generic_event_t use event_base, only: event_callback_t use particles, only: particle_set_t use eio_data use eio_base use eio_direct, only: eio_direct_t use eio_raw use eio_ascii use eio_dump use eio_callback use eval_trees use model_data, only: model_data_t use models use rt_data use event_streams use decays_ut, only: prepare_testbed use process, only: process_t use process_stacks, only: process_entry_t use process_configurations_ut, only: prepare_test_library use compilations, only: compile_library use integrations, only: integrate_process use simulations use restricted_subprocesses_uti, only: prepare_resonance_test_library <> <> <> contains <> <> end module simulations_uti @ %def simulations_uti @ API: driver for the unit tests below. <>= public :: simulations_test <>= subroutine simulations_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine simulations_test @ %def simulations_test @ \subsubsection{Initialization} Initialize a [[simulation_t]] object, including the embedded event records. <>= call test (simulations_1, "simulations_1", & "initialization", & u, results) <>= public :: simulations_1 <>= subroutine simulations_1 (u) integer, intent(in) :: u type(string_t) :: libname, procname1, procname2 type(rt_data_t), target :: global type(simulation_t), target :: simulation write (u, "(A)") "* Test output: simulations_1" write (u, "(A)") "* Purpose: initialize simulation" write (u, "(A)") write (u, "(A)") "* Initialize processes" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_1a" procname1 = "simulation_1p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("simulations1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) procname2 = "sim_extra" call prepare_test_library (global, libname, 1, [procname2]) call compile_library (libname, global) call global%set_string (var_str ("$run_id"), & var_str ("simulations2"), is_known = .true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call global%set_string (var_str ("$sample"), & var_str ("sim1"), is_known = .true.) call integrate_process (procname2, global, local_stack=.true.) call simulation%init ([procname1, procname2], .false., .true., global) call simulation%init_process_selector () call simulation%write (u) write (u, "(A)") write (u, "(A)") "* Write the event record for the first process" write (u, "(A)") call simulation%write_event (u, i_prc = 1) write (u, "(A)") write (u, "(A)") "* Cleanup" call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_1" end subroutine simulations_1 @ %def simulations_1 @ \subsubsection{Weighted events} Generate events for a single process. <>= call test (simulations_2, "simulations_2", & "weighted events", & u, results) <>= public :: simulations_2 <>= subroutine simulations_2 (u) integer, intent(in) :: u type(string_t) :: libname, procname1 type(rt_data_t), target :: global type(simulation_t), target :: simulation type(event_sample_data_t) :: data write (u, "(A)") "* Test output: simulations_2" write (u, "(A)") "* Purpose: generate events for a single process" write (u, "(A)") write (u, "(A)") "* Initialize processes" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_2a" procname1 = "simulation_2p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("simulations1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call global%set_log (var_str ("?unweighted"), & .false., is_known = .true.) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () data = simulation%get_data () call data%write (u) write (u, "(A)") write (u, "(A)") "* Generate three events" write (u, "(A)") call simulation%generate (3) call simulation%write (u) write (u, "(A)") write (u, "(A)") "* Write the event record for the last event" write (u, "(A)") call simulation%write_event (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_2" end subroutine simulations_2 @ %def simulations_2 @ \subsubsection{Unweighted events} Generate events for a single process. <>= call test (simulations_3, "simulations_3", & "unweighted events", & u, results) <>= public :: simulations_3 <>= subroutine simulations_3 (u) integer, intent(in) :: u type(string_t) :: libname, procname1 type(rt_data_t), target :: global type(simulation_t), target :: simulation type(event_sample_data_t) :: data write (u, "(A)") "* Test output: simulations_3" write (u, "(A)") "* Purpose: generate unweighted events & &for a single process" write (u, "(A)") write (u, "(A)") "* Initialize processes" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_3a" procname1 = "simulation_3p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("simulations1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () data = simulation%get_data () call data%write (u) write (u, "(A)") write (u, "(A)") "* Generate three events" write (u, "(A)") call simulation%generate (3) call simulation%write (u) write (u, "(A)") write (u, "(A)") "* Write the event record for the last event" write (u, "(A)") call simulation%write_event (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_3" end subroutine simulations_3 @ %def simulations_3 @ \subsubsection{Simulating process with structure functions} Generate events for a single process. <>= call test (simulations_4, "simulations_4", & "process with structure functions", & u, results) <>= public :: simulations_4 <>= subroutine simulations_4 (u) integer, intent(in) :: u type(string_t) :: libname, procname1 type(rt_data_t), target :: global type(flavor_t) :: flv type(string_t) :: name type(simulation_t), target :: simulation type(event_sample_data_t) :: data write (u, "(A)") "* Test output: simulations_4" write (u, "(A)") "* Purpose: generate events for a single process & &with structure functions" write (u, "(A)") write (u, "(A)") "* Initialize processes" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_4a" procname1 = "simulation_4p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("wood"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .true., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%model_set_real (var_str ("ms"), & 0._default) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call reset_interaction_counter () call flv%init (25, global%model) name = flv%get_name () call global%beam_structure%init_sf ([name, name], [1]) call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1")) write (u, "(A)") "* Integrate" write (u, "(A)") call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call global%set_log (var_str ("?unweighted"), & .false., is_known = .true.) call global%set_string (var_str ("$sample"), & var_str ("simulations4"), is_known = .true.) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () data = simulation%get_data () call data%write (u) write (u, "(A)") write (u, "(A)") "* Generate three events" write (u, "(A)") call simulation%generate (3) call simulation%write (u) write (u, "(A)") write (u, "(A)") "* Write the event record for the last event" write (u, "(A)") call simulation%write_event (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_4" end subroutine simulations_4 @ %def simulations_4 @ \subsubsection{Event I/O} Generate event for a test process, write to file and reread. <>= call test (simulations_5, "simulations_5", & "raw event I/O", & u, results) <>= public :: simulations_5 <>= subroutine simulations_5 (u) integer, intent(in) :: u type(string_t) :: libname, procname1, sample type(rt_data_t), target :: global class(eio_t), allocatable :: eio type(simulation_t), allocatable, target :: simulation write (u, "(A)") "* Test output: simulations_5" write (u, "(A)") "* Purpose: generate events for a single process" write (u, "(A)") "* write to file and reread" write (u, "(A)") write (u, "(A)") "* Initialize processes" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_5a" procname1 = "simulation_5p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("simulations5"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call global%set_log (var_str ("?unweighted"), & .false., is_known = .true.) sample = "simulations5" call global%set_string (var_str ("$sample"), & sample, is_known = .true.) allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () write (u, "(A)") "* Initialize raw event file" write (u, "(A)") allocate (eio_raw_t :: eio) call eio%init_out (sample) write (u, "(A)") "* Generate an event" write (u, "(A)") call simulation%generate (1) call simulation%write_event (u) call simulation%write_event (eio) call eio%final () deallocate (eio) call simulation%final () deallocate (simulation) write (u, "(A)") write (u, "(A)") "* Re-read the event from file" write (u, "(A)") call global%set_log (var_str ("?update_sqme"), & .true., is_known = .true.) call global%set_log (var_str ("?update_weight"), & .true., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () allocate (eio_raw_t :: eio) call eio%init_in (sample) call simulation%read_event (eio) call simulation%write_event (u) write (u, "(A)") write (u, "(A)") "* Recalculate process instance" write (u, "(A)") call simulation%recalculate () call simulation%evaluate_expressions () call simulation%write_event (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_5" end subroutine simulations_5 @ %def simulations_5 @ \subsubsection{Event I/O} Generate event for a real process with structure functions, write to file and reread. <>= call test (simulations_6, "simulations_6", & "raw event I/O with structure functions", & u, results) <>= public :: simulations_6 <>= subroutine simulations_6 (u) integer, intent(in) :: u type(string_t) :: libname, procname1, sample type(rt_data_t), target :: global class(eio_t), allocatable :: eio type(simulation_t), allocatable, target :: simulation type(flavor_t) :: flv type(string_t) :: name write (u, "(A)") "* Test output: simulations_6" write (u, "(A)") "* Purpose: generate events for a single process" write (u, "(A)") "* write to file and reread" write (u, "(A)") write (u, "(A)") "* Initialize process and integrate" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_6" procname1 = "simulation_6p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("wood"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .true., is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%model_set_real (var_str ("ms"), & 0._default) call flv%init (25, global%model) name = flv%get_name () call global%beam_structure%init_sf ([name, name], [1]) call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1")) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call reset_interaction_counter () call global%set_log (var_str ("?unweighted"), & .false., is_known = .true.) sample = "simulations6" call global%set_string (var_str ("$sample"), & sample, is_known = .true.) allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () write (u, "(A)") "* Initialize raw event file" write (u, "(A)") allocate (eio_raw_t :: eio) call eio%init_out (sample) write (u, "(A)") "* Generate an event" write (u, "(A)") call simulation%generate (1) call pacify (simulation) call simulation%write_event (u, verbose = .true., testflag = .true.) call simulation%write_event (eio) call eio%final () deallocate (eio) call simulation%final () deallocate (simulation) write (u, "(A)") write (u, "(A)") "* Re-read the event from file" write (u, "(A)") call reset_interaction_counter () call global%set_log (var_str ("?update_sqme"), & .true., is_known = .true.) call global%set_log (var_str ("?update_weight"), & .true., is_known = .true.) allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () allocate (eio_raw_t :: eio) call eio%init_in (sample) call simulation%read_event (eio) call simulation%write_event (u, verbose = .true., testflag = .true.) write (u, "(A)") write (u, "(A)") "* Recalculate process instance" write (u, "(A)") call simulation%recalculate () call simulation%evaluate_expressions () call simulation%write_event (u, verbose = .true., testflag = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_6" end subroutine simulations_6 @ %def simulations_6 @ \subsubsection{Automatic Event I/O} Generate events with raw-format event file as cache: generate, reread, append. <>= call test (simulations_7, "simulations_7", & "automatic raw event I/O", & u, results) <>= public :: simulations_7 <>= subroutine simulations_7 (u) integer, intent(in) :: u type(string_t) :: libname, procname1, sample type(rt_data_t), target :: global type(string_t), dimension(0) :: empty_string_array type(event_sample_data_t) :: data type(event_stream_array_t) :: es_array type(simulation_t), allocatable, target :: simulation type(flavor_t) :: flv type(string_t) :: name write (u, "(A)") "* Test output: simulations_7" write (u, "(A)") "* Purpose: generate events for a single process" write (u, "(A)") "* write to file and reread" write (u, "(A)") write (u, "(A)") "* Initialize process and integrate" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_7" procname1 = "simulation_7p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("wood"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .true., is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%model_set_real (var_str ("ms"), & 0._default) call flv%init (25, global%model) name = flv%get_name () call global%beam_structure%init_sf ([name, name], [1]) call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1")) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call reset_interaction_counter () call global%set_log (var_str ("?unweighted"), & .false., is_known = .true.) sample = "simulations7" call global%set_string (var_str ("$sample"), & sample, is_known = .true.) allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () write (u, "(A)") "* Initialize raw event file" write (u, "(A)") data%md5sum_prc = simulation%get_md5sum_prc () data%md5sum_cfg = simulation%get_md5sum_cfg () call es_array%init (sample, [var_str ("raw")], global, data) write (u, "(A)") "* Generate an event" write (u, "(A)") call simulation%generate (1, es_array) call es_array%final () call simulation%final () deallocate (simulation) write (u, "(A)") "* Re-read the event from file and generate another one" write (u, "(A)") call global%set_log (& var_str ("?rebuild_events"), .false., is_known = .true.) call reset_interaction_counter () allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () data%md5sum_prc = simulation%get_md5sum_prc () data%md5sum_cfg = simulation%get_md5sum_cfg () call es_array%init (sample, empty_string_array, global, data, & input = var_str ("raw")) call simulation%generate (2, es_array) call pacify (simulation) call simulation%write_event (u, verbose = .true.) call es_array%final () call simulation%final () deallocate (simulation) write (u, "(A)") write (u, "(A)") "* Re-read both events from file" write (u, "(A)") call reset_interaction_counter () allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () data%md5sum_prc = simulation%get_md5sum_prc () data%md5sum_cfg = simulation%get_md5sum_cfg () call es_array%init (sample, empty_string_array, global, data, & input = var_str ("raw")) call simulation%generate (2, es_array) call pacify (simulation) call simulation%write_event (u, verbose = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call es_array%final () call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_7" end subroutine simulations_7 @ %def simulations_7 @ \subsubsection{Rescanning Events} Generate events and rescan the resulting raw event file. <>= call test (simulations_8, "simulations_8", & "rescan raw event file", & u, results) <>= public :: simulations_8 <>= subroutine simulations_8 (u) integer, intent(in) :: u type(string_t) :: libname, procname1, sample type(rt_data_t), target :: global type(string_t), dimension(0) :: empty_string_array type(event_sample_data_t) :: data type(event_stream_array_t) :: es_array type(simulation_t), allocatable, target :: simulation type(flavor_t) :: flv type(string_t) :: name write (u, "(A)") "* Test output: simulations_8" write (u, "(A)") "* Purpose: generate events for a single process" write (u, "(A)") "* write to file and rescan" write (u, "(A)") write (u, "(A)") "* Initialize process and integrate" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_8" procname1 = "simulation_8p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("wood"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .true., is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%model_set_real (var_str ("ms"), & 0._default) call flv%init (25, global%model) name = flv%get_name () call global%beam_structure%init_sf ([name, name], [1]) call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1")) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call reset_interaction_counter () call global%set_log (var_str ("?unweighted"), & .false., is_known = .true.) sample = "simulations8" call global%set_string (var_str ("$sample"), & sample, is_known = .true.) allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () write (u, "(A)") "* Initialize raw event file" write (u, "(A)") data%md5sum_prc = simulation%get_md5sum_prc () data%md5sum_cfg = simulation%get_md5sum_cfg () write (u, "(1x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'" write (u, "(1x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'" call es_array%init (sample, [var_str ("raw")], global, & data) write (u, "(A)") write (u, "(A)") "* Generate an event" write (u, "(A)") call simulation%generate (1, es_array) call pacify (simulation) call simulation%write_event (u, verbose = .true., testflag = .true.) call es_array%final () call simulation%final () deallocate (simulation) write (u, "(A)") write (u, "(A)") "* Re-read the event from file" write (u, "(A)") call reset_interaction_counter () allocate (simulation) call simulation%init ([procname1], .false., .false., global) call simulation%init_process_selector () data%md5sum_prc = simulation%get_md5sum_prc () data%md5sum_cfg = "" write (u, "(1x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'" write (u, "(1x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'" call es_array%init (sample, empty_string_array, global, data, & input = var_str ("raw"), input_sample = sample, allow_switch = .false.) call simulation%rescan (1, es_array, global = global) write (u, "(A)") call pacify (simulation) call simulation%write_event (u, verbose = .true., testflag = .true.) call es_array%final () call simulation%final () deallocate (simulation) write (u, "(A)") write (u, "(A)") "* Re-read again and recalculate" write (u, "(A)") call reset_interaction_counter () call global%set_log (var_str ("?update_sqme"), & .true., is_known = .true.) call global%set_log (var_str ("?update_event"), & .true., is_known = .true.) allocate (simulation) call simulation%init ([procname1], .false., .false., global) call simulation%init_process_selector () data%md5sum_prc = simulation%get_md5sum_prc () data%md5sum_cfg = "" write (u, "(1x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'" write (u, "(1x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'" call es_array%init (sample, empty_string_array, global, data, & input = var_str ("raw"), input_sample = sample, allow_switch = .false.) call simulation%rescan (1, es_array, global = global) write (u, "(A)") call pacify (simulation) call simulation%write_event (u, verbose = .true., testflag = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call es_array%final () call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_8" end subroutine simulations_8 @ %def simulations_8 @ \subsubsection{Rescanning Check} Generate events and rescan with process mismatch. <>= call test (simulations_9, "simulations_9", & "rescan mismatch", & u, results) <>= public :: simulations_9 <>= subroutine simulations_9 (u) integer, intent(in) :: u type(string_t) :: libname, procname1, sample type(rt_data_t), target :: global type(string_t), dimension(0) :: empty_string_array type(event_sample_data_t) :: data type(event_stream_array_t) :: es_array type(simulation_t), allocatable, target :: simulation type(flavor_t) :: flv type(string_t) :: name logical :: error write (u, "(A)") "* Test output: simulations_9" write (u, "(A)") "* Purpose: generate events for a single process" write (u, "(A)") "* write to file and rescan" write (u, "(A)") write (u, "(A)") "* Initialize process and integrate" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_9" procname1 = "simulation_9p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("wood"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("vamp"), is_known = .true.) call global%set_log (var_str ("?use_vamp_equivalences"),& .true., is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%model_set_real (var_str ("ms"), & 0._default) call flv%init (25, global%model) name = flv%get_name () call global%beam_structure%init_sf ([name, name], [1]) call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1")) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call reset_interaction_counter () call global%set_log (var_str ("?unweighted"), & .false., is_known = .true.) sample = "simulations9" call global%set_string (var_str ("$sample"), & sample, is_known = .true.) allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () call simulation%write (u) write (u, "(A)") write (u, "(A)") "* Initialize raw event file" write (u, "(A)") data%md5sum_prc = simulation%get_md5sum_prc () data%md5sum_cfg = simulation%get_md5sum_cfg () write (u, "(1x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'" write (u, "(1x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'" call es_array%init (sample, [var_str ("raw")], global, & data) write (u, "(A)") write (u, "(A)") "* Generate an event" write (u, "(A)") call simulation%generate (1, es_array) call es_array%final () call simulation%final () deallocate (simulation) write (u, "(A)") "* Initialize event generation for different parameters" write (u, "(A)") call reset_interaction_counter () allocate (simulation) call simulation%init ([procname1, procname1], .false., .false., global) call simulation%init_process_selector () call simulation%write (u) write (u, "(A)") write (u, "(A)") "* Attempt to re-read the events (should fail)" write (u, "(A)") data%md5sum_prc = simulation%get_md5sum_prc () data%md5sum_cfg = "" write (u, "(1x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'" write (u, "(1x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'" call es_array%init (sample, empty_string_array, global, data, & input = var_str ("raw"), input_sample = sample, & allow_switch = .false., error = error) write (u, "(1x,A,L1)") "error = ", error call simulation%rescan (1, es_array, global = global) call es_array%final () call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_9" end subroutine simulations_9 @ %def simulations_9 @ \subsubsection{Alternative weights} Generate an event for a single process and reweight it in a simultaneous calculation. <>= call test (simulations_10, "simulations_10", & "alternative weight", & u, results) <>= public :: simulations_10 <>= subroutine simulations_10 (u) integer, intent(in) :: u type(string_t) :: libname, procname1, expr_text type(rt_data_t), target :: global type(rt_data_t), dimension(1), target :: alt_env type(ifile_t) :: ifile type(stream_t) :: stream type(parse_tree_t) :: pt_weight type(simulation_t), target :: simulation type(event_sample_data_t) :: data write (u, "(A)") "* Test output: simulations_10" write (u, "(A)") "* Purpose: reweight event" write (u, "(A)") write (u, "(A)") "* Initialize processes" write (u, "(A)") call syntax_model_file_init () call syntax_pexpr_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_10a" procname1 = "simulation_10p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("simulations1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize alternative environment with custom weight" write (u, "(A)") call alt_env(1)%local_init (global) call alt_env(1)%activate () expr_text = "2" write (u, "(A,A)") "weight = ", char (expr_text) write (u, *) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_weight, stream, .true.) call stream_final (stream) alt_env(1)%pn%weight_expr => pt_weight%get_root_ptr () call alt_env(1)%write_expr (u) write (u, "(A)") write (u, "(A)") "* Initialize event generation" write (u, "(A)") call global%set_log (var_str ("?unweighted"), & .false., is_known = .true.) call simulation%init ([procname1], .true., .true., global, alt_env=alt_env) call simulation%init_process_selector () data = simulation%get_data () call data%write (u) write (u, "(A)") write (u, "(A)") "* Generate an event" write (u, "(A)") call simulation%generate (1) call simulation%write (u) write (u, "(A)") write (u, "(A)") "* Write the event record for the last event" write (u, "(A)") call simulation%write_event (u) write (u, "(A)") write (u, "(A)") "* Write the event record for the alternative setup" write (u, "(A)") call simulation%write_alt_event (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call simulation%final () call global%final () call syntax_model_file_final () call syntax_pexpr_final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_10" end subroutine simulations_10 @ %def simulations_10 @ \subsubsection{Decays} Generate an event with subsequent partonic decays. <>= call test (simulations_11, "simulations_11", & "decay", & u, results) <>= public :: simulations_11 <>= subroutine simulations_11 (u) integer, intent(in) :: u type(rt_data_t), target :: global type(prclib_entry_t), pointer :: lib type(string_t) :: prefix, procname1, procname2 type(simulation_t), target :: simulation write (u, "(A)") "* Test output: simulations_11" write (u, "(A)") "* Purpose: apply decay" write (u, "(A)") write (u, "(A)") "* Initialize processes" write (u, "(A)") call syntax_model_file_init () call global%global_init () allocate (lib) call global%add_prclib (lib) call global%set_int (var_str ("seed"), & 0, is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) prefix = "simulation_11" procname1 = prefix // "_p" procname2 = prefix // "_d" call prepare_testbed & (global%prclib, global%process_stack, & prefix, global%os_data, & scattering=.true., decay=.true.) call global%select_model (var_str ("Test")) call global%model%set_par (var_str ("ff"), 0.4_default) call global%model%set_par (var_str ("mf"), & global%model%get_real (var_str ("ff")) & * global%model%get_real (var_str ("ms"))) call global%model%set_unstable (25, [procname2]) write (u, "(A)") "* Initialize simulation object" write (u, "(A)") call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () write (u, "(A)") "* Generate event" write (u, "(A)") call simulation%generate (1) call simulation%write (u) write (u, *) call simulation%write_event (u) write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") call simulation%final () call global%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_11" end subroutine simulations_11 @ %def simulations_11 @ \subsubsection{Split Event Files} Generate event for a real process with structure functions and write to file, accepting a limit for the number of events per file. <>= call test (simulations_12, "simulations_12", & "split event files", & u, results) <>= public :: simulations_12 <>= subroutine simulations_12 (u) integer, intent(in) :: u type(string_t) :: libname, procname1, sample type(rt_data_t), target :: global class(eio_t), allocatable :: eio type(simulation_t), allocatable, target :: simulation type(flavor_t) :: flv integer :: i_evt write (u, "(A)") "* Test output: simulations_12" write (u, "(A)") "* Purpose: generate events for a single process" write (u, "(A)") "* and write to split event files" write (u, "(A)") write (u, "(A)") "* Initialize process and integrate" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_12" procname1 = "simulation_12p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%model_set_real (var_str ("ms"), & 0._default) call flv%init (25, global%model) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call global%set_log (var_str ("?unweighted"), & .false., is_known = .true.) sample = "simulations_12" call global%set_string (var_str ("$sample"), & sample, is_known = .true.) call global%set_int (var_str ("sample_split_n_evt"), & 2, is_known = .true.) call global%set_int (var_str ("sample_split_index"), & 42, is_known = .true.) allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () call simulation%write (u) write (u, "(A)") write (u, "(A)") "* Initialize ASCII event file" write (u, "(A)") allocate (eio_ascii_short_t :: eio) select type (eio) class is (eio_ascii_t); call eio%set_parameters () end select call eio%init_out (sample, data = simulation%get_data ()) write (u, "(A)") "* Generate 5 events, distributed among three files" do i_evt = 1, 5 call simulation%generate (1) call simulation%write_event (eio) end do call eio%final () deallocate (eio) call simulation%final () deallocate (simulation) write (u, *) call display_file ("simulations_12.42.short.evt", u) write (u, *) call display_file ("simulations_12.43.short.evt", u) write (u, *) call display_file ("simulations_12.44.short.evt", u) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_12" end subroutine simulations_12 @ %def simulations_12 @ Auxiliary: display file contents. <>= public :: display_file <>= subroutine display_file (file, u) use io_units, only: free_unit character(*), intent(in) :: file integer, intent(in) :: u character(256) :: buffer integer :: u_file write (u, "(3A)") "* Contents of file '", file, "':" write (u, *) u_file = free_unit () open (u_file, file = file, action = "read", status = "old") do read (u_file, "(A)", end = 1) buffer write (u, "(A)") trim (buffer) end do 1 continue end subroutine display_file @ %def display_file @ \subsubsection{Callback} Generate events and execute a callback in place of event I/O. <>= call test (simulations_13, "simulations_13", & "callback", & u, results) <>= public :: simulations_13 <>= subroutine simulations_13 (u) integer, intent(in) :: u type(string_t) :: libname, procname1, sample type(rt_data_t), target :: global class(eio_t), allocatable :: eio type(simulation_t), allocatable, target :: simulation type(flavor_t) :: flv integer :: i_evt type(simulations_13_callback_t) :: event_callback write (u, "(A)") "* Test output: simulations_13" write (u, "(A)") "* Purpose: generate events for a single process" write (u, "(A)") "* and execute callback" write (u, "(A)") write (u, "(A)") "* Initialize process and integrate" write (u, "(A)") call syntax_model_file_init () call global%global_init () call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) libname = "simulation_13" procname1 = "simulation_13p" call prepare_test_library (global, libname, 1, [procname1]) call compile_library (libname, global) call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_string (var_str ("$method"), & var_str ("unit_test"), is_known = .true.) call global%set_string (var_str ("$phs_method"), & var_str ("single"), is_known = .true.) call global%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known = .true.) call global%set_log (var_str ("?vis_history"),& .false., is_known = .true.) call global%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call flv%init (25, global%model) call global%it_list%init ([1], [1000]) call global%set_string (var_str ("$run_id"), & var_str ("r1"), is_known = .true.) call integrate_process (procname1, global, local_stack=.true.) write (u, "(A)") "* Initialize event generation" write (u, "(A)") call global%set_log (var_str ("?unweighted"), & .false., is_known = .true.) sample = "simulations_13" call global%set_string (var_str ("$sample"), & sample, is_known = .true.) allocate (simulation) call simulation%init ([procname1], .true., .true., global) call simulation%init_process_selector () write (u, "(A)") "* Prepare callback object" write (u, "(A)") event_callback%u = u call global%set_event_callback (event_callback) write (u, "(A)") "* Initialize callback I/O object" write (u, "(A)") allocate (eio_callback_t :: eio) select type (eio) class is (eio_callback_t) call eio%set_parameters (callback = event_callback, & count_interval = 3) end select call eio%init_out (sample, data = simulation%get_data ()) write (u, "(A)") "* Generate 7 events, with callback every 3 events" write (u, "(A)") do i_evt = 1, 7 call simulation%generate (1) call simulation%write_event (eio) end do call eio%final () deallocate (eio) call simulation%final () deallocate (simulation) write (u, "(A)") write (u, "(A)") "* Cleanup" call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_13" end subroutine simulations_13 @ %def simulations_13 @ The callback object and procedure. In the type extension, we can store the output channel [[u]] so we know where to write into. <>= type, extends (event_callback_t) :: simulations_13_callback_t integer :: u contains procedure :: write => simulations_13_callback_write procedure :: proc => simulations_13_callback end type simulations_13_callback_t @ %def simulations_13_callback_t <>= subroutine simulations_13_callback_write (event_callback, unit) class(simulations_13_callback_t), intent(in) :: event_callback integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Hello" end subroutine simulations_13_callback_write subroutine simulations_13_callback (event_callback, i, event) class(simulations_13_callback_t), intent(in) :: event_callback integer(i64), intent(in) :: i class(generic_event_t), intent(in) :: event write (event_callback%u, "(A,I0)") "hello event #", i end subroutine simulations_13_callback @ %def simulations_13_callback_write @ %def simulations_13_callback @ \subsubsection{Resonant subprocess setup} Prepare a process with resonances and enter resonant subprocesses in the simulation object. Select a kinematics configuration and compute probabilities for resonant subprocesses. The process and its initialization is taken from [[processes_18]], but we need a complete \oMega\ matrix element here. <>= call test (simulations_14, "simulations_14", & "resonant subprocesses evaluation", & u, results) <>= public :: simulations_14 <>= subroutine simulations_14 (u) integer, intent(in) :: u type(string_t) :: libname, libname_generated type(string_t) :: procname type(string_t) :: model_name type(rt_data_t), target :: global type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib class(model_t), pointer :: model class(model_data_t), pointer :: model_data type(simulation_t), target :: simulation type(particle_set_t) :: pset type(eio_direct_t) :: eio_in type(eio_dump_t) :: eio_out real(default) :: sqrts, mw, pp real(default), dimension(3) :: p3 type(vector4_t), dimension(:), allocatable :: p real(default), dimension(:), allocatable :: m integer :: u_verbose, i real(default) :: sqme_proc real(default), dimension(:), allocatable :: sqme real(default) :: on_shell_limit integer, dimension(:), allocatable :: i_array real(default), dimension(:), allocatable :: prob_array write (u, "(A)") "* Test output: simulations_14" write (u, "(A)") "* Purpose: construct resonant subprocesses & &in the simulation object" write (u, "(A)") write (u, "(A)") "* Build and load a test library with one process" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () libname = "simulations_14_lib" procname = "simulations_14_p" call global%global_init () call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_log (var_str ("?update_sqme"), & .true., is_known = .true.) call global%set_log (var_str ("?update_weight"), & .true., is_known = .true.) call global%set_log (var_str ("?update_event"), & .true., is_known = .true.) model_name = "SM" call global%select_model (model_name) allocate (model) call model%init_instance (global%model) model_data => model write (u, "(A)") "* Initialize process library and process" write (u, "(A)") allocate (lib_entry) call lib_entry%init (libname) lib => lib_entry%process_library_t call global%add_prclib (lib_entry) call prepare_resonance_test_library & (lib, libname, procname, model_data, global, u) write (u, "(A)") write (u, "(A)") "* Initialize simulation object & &with resonant subprocesses" write (u, "(A)") call global%set_log (var_str ("?resonance_history"), & .true., is_known = .true.) call global%set_real (var_str ("resonance_on_shell_limit"), & 10._default, is_known = .true.) call simulation%init ([procname], & integrate=.false., generate=.false., local=global) call simulation%write_resonant_subprocess_data (u, 1) write (u, "(A)") write (u, "(A)") "* Resonant subprocesses: generated library" write (u, "(A)") libname_generated = procname // "_R" lib => global%prclib_stack%get_library_ptr (libname_generated) if (associated (lib)) call lib%write (u, libpath=.false.) write (u, "(A)") write (u, "(A)") "* Generated process stack" write (u, "(A)") call global%process_stack%show (u) write (u, "(A)") write (u, "(A)") "* Particle set" write (u, "(A)") pset = simulation%get_hard_particle_set (1) call pset%write (u) write (u, "(A)") write (u, "(A)") "* Initialize object for direct access" write (u, "(A)") call eio_in%init_direct & (n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 3, & pdg = [-11, 11, 1, -2, 24], model=global%model) call eio_in%set_selection_indices (1, 1, 1, 1) sqrts = global%get_rval (var_str ("sqrts")) mw = 80._default ! deliberately slightly different from true mw pp = sqrt (sqrts**2 - 4 * mw**2) / 2 allocate (p (5), m (5)) p(1) = vector4_moving (sqrts/2, sqrts/2, 3) m(1) = 0 p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) m(2) = 0 p3(1) = pp/2 p3(2) = mw/2 p3(3) = 0 p(3) = vector4_moving (sqrts/4, vector3_moving (p3)) m(3) = 0 p3(2) = -mw/2 p(4) = vector4_moving (sqrts/4, vector3_moving (p3)) m(4) = 0 p(5) = vector4_moving (sqrts/2,-pp, 1) m(5) = mw call eio_in%set_momentum (p, m**2) call eio_in%write (u) write (u, "(A)") write (u, "(A)") "* Transfer and show particle set" write (u, "(A)") call simulation%read_event (eio_in) pset = simulation%get_hard_particle_set (1) call pset%write (u) write (u, "(A)") write (u, "(A)") "* (Re)calculate matrix element" write (u, "(A)") call simulation%recalculate (recover_phs = .false.) call simulation%evaluate_transforms () write (u, "(A)") "* Show event with sqme" write (u, "(A)") call eio_out%set_parameters (unit = u, & weights = .true., pacify = .true., compressed = .true.) call eio_out%init_out (var_str ("")) call simulation%write_event (eio_out) write (u, "(A)") write (u, "(A)") "* Write event to separate file & &'simulations_14_event_verbose.log'" u_verbose = free_unit () open (unit = u_verbose, file = "simulations_14_event_verbose.log", & status = "replace", action = "write") call simulation%write (u_verbose) write (u_verbose, *) call simulation%write_event (u_verbose, verbose =.true., testflag = .true.) close (u_verbose) write (u, "(A)") write (u, "(A)") "* Cleanup" call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_14" end subroutine simulations_14 @ %def simulations_14 @ \subsubsection{Resonant subprocess simulation} Prepare a process with resonances and enter resonant subprocesses in the simulation object. Simulate events with selection of resonance histories. The process and its initialization is taken from [[processes_18]], but we need a complete \oMega\ matrix element here. <>= call test (simulations_15, "simulations_15", & "resonant subprocesses in simulation", & u, results) <>= public :: simulations_15 <>= subroutine simulations_15 (u) integer, intent(in) :: u type(string_t) :: libname, libname_generated type(string_t) :: procname type(string_t) :: model_name type(rt_data_t), target :: global type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib class(model_t), pointer :: model class(model_data_t), pointer :: model_data type(simulation_t), target :: simulation real(default) :: sqrts type(eio_dump_t) :: eio_out integer :: u_verbose write (u, "(A)") "* Test output: simulations_15" write (u, "(A)") "* Purpose: generate event with resonant subprocess" write (u, "(A)") write (u, "(A)") "* Build and load a test library with one process" write (u, "(A)") call syntax_model_file_init () call syntax_phs_forest_init () libname = "simulations_15_lib" procname = "simulations_15_p" call global%global_init () call global%append_log (& var_str ("?rebuild_phase_space"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_grids"), .true., intrinsic = .true.) call global%append_log (& var_str ("?rebuild_events"), .true., intrinsic = .true.) call global%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) call global%set_int (var_str ("seed"), & 0, is_known = .true.) call global%set_real (var_str ("sqrts"),& 1000._default, is_known = .true.) call global%set_log (var_str ("?recover_beams"), & .false., is_known = .true.) call global%set_log (var_str ("?update_sqme"), & .true., is_known = .true.) call global%set_log (var_str ("?update_weight"), & .true., is_known = .true.) call global%set_log (var_str ("?update_event"), & .true., is_known = .true.) call global%set_log (var_str ("?resonance_history"), & .true., is_known = .true.) call global%set_real (var_str ("resonance_on_shell_limit"), & 10._default, is_known = .true.) model_name = "SM" call global%select_model (model_name) allocate (model) call model%init_instance (global%model) model_data => model write (u, "(A)") "* Initialize process library and process" write (u, "(A)") allocate (lib_entry) call lib_entry%init (libname) lib => lib_entry%process_library_t call global%add_prclib (lib_entry) call prepare_resonance_test_library & (lib, libname, procname, model_data, global, u) write (u, "(A)") write (u, "(A)") "* Initialize simulation object & &with resonant subprocesses" write (u, "(A)") call global%it_list%init ([1], [1000]) call simulation%init ([procname], & integrate=.true., generate=.true., local=global) call simulation%write_resonant_subprocess_data (u, 1) write (u, "(A)") write (u, "(A)") "* Generate event" write (u, "(A)") call simulation%init_process_selector () call simulation%generate (1) call eio_out%set_parameters (unit = u, & weights = .true., pacify = .true., compressed = .true.) call eio_out%init_out (var_str ("")) call simulation%write_event (eio_out) write (u, "(A)") write (u, "(A)") "* Write event to separate file & &'simulations_15_event_verbose.log'" u_verbose = free_unit () open (unit = u_verbose, file = "simulations_15_event_verbose.log", & status = "replace", action = "write") call simulation%write (u_verbose) write (u_verbose, *) call simulation%write_event (u_verbose, verbose =.true., testflag = .true.) close (u_verbose) write (u, "(A)") write (u, "(A)") "* Cleanup" call simulation%final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: simulations_15" end subroutine simulations_15 @ %def simulations_15 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{More Unit Tests} This chapter collects some procedures for testing that can't be provided at the point where the corresponding modules are defined, because they use other modules of a different level. (We should move them back, collecting the high-level functionality in init/final hooks that we can set at runtime.) \section{Expression Testing} Expression objects are part of process and event objects, but the process and event object modules should not depend on the implementation of expressions. Here, we collect unit tests that depend on expression implementation. <<[[expr_tests_ut.f90]]>>= <> module expr_tests_ut use unit_tests use expr_tests_uti <> <> contains <> end module expr_tests_ut @ %def expr_tests_ut @ <<[[expr_tests_uti.f90]]>>= <> module expr_tests_uti <> <> use format_defs, only: FMT_12 use format_utils, only: write_separator use os_interface use sm_qcd use lorentz use ifiles use lexers use parser use model_data use interactions, only: reset_interaction_counter use process_libraries use subevents use subevt_expr use rng_base use mci_base use phs_base use variables, only: var_list_t use eval_trees use models use prc_core use prc_test use process, only: process_t use instances, only: process_instance_t use events use rng_base_ut, only: rng_test_factory_t use phs_base_ut, only: phs_test_config_t <> <> contains <> <> end module expr_tests_uti @ %def expr_tests_uti @ \subsection{Test} This is the master for calling self-test procedures. <>= public :: subevt_expr_test <>= subroutine subevt_expr_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine subevt_expr_test @ %def subevt_expr_test @ \subsubsection{Parton-event expressions} <>= call test (subevt_expr_1, "subevt_expr_1", & "parton-event expressions", & u, results) <>= public :: subevt_expr_1 <>= subroutine subevt_expr_1 (u) integer, intent(in) :: u type(string_t) :: expr_text type(ifile_t) :: ifile type(stream_t) :: stream type(parse_tree_t) :: pt_cuts, pt_scale, pt_fac_scale, pt_ren_scale type(parse_tree_t) :: pt_weight type(parse_node_t), pointer :: pn_cuts, pn_scale, pn_fac_scale, pn_ren_scale type(parse_node_t), pointer :: pn_weight type(eval_tree_factory_t) :: expr_factory type(os_data_t) :: os_data type(model_t), target :: model type(parton_expr_t), target :: expr real(default) :: E, Ex, m type(vector4_t), dimension(6) :: p integer :: i, pdg logical :: passed real(default) :: scale, fac_scale, ren_scale, weight write (u, "(A)") "* Test output: subevt_expr_1" write (u, "(A)") "* Purpose: Set up a subevt and associated & &process-specific expressions" write (u, "(A)") call syntax_pexpr_init () call syntax_model_file_init () call os_data%init () call model%read (var_str ("Test.mdl"), os_data) write (u, "(A)") "* Expression texts" write (u, "(A)") expr_text = "all Pt > 100 [s]" write (u, "(A,A)") "cuts = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_lexpr (pt_cuts, stream, .true.) call stream_final (stream) pn_cuts => pt_cuts%get_root_ptr () expr_text = "sqrts" write (u, "(A,A)") "scale = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_scale, stream, .true.) call stream_final (stream) pn_scale => pt_scale%get_root_ptr () expr_text = "sqrts_hat" write (u, "(A,A)") "fac_scale = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_fac_scale, stream, .true.) call stream_final (stream) pn_fac_scale => pt_fac_scale%get_root_ptr () expr_text = "100" write (u, "(A,A)") "ren_scale = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_ren_scale, stream, .true.) call stream_final (stream) pn_ren_scale => pt_ren_scale%get_root_ptr () expr_text = "n_tot - n_in - n_out" write (u, "(A,A)") "weight = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_weight, stream, .true.) call stream_final (stream) pn_weight => pt_weight%get_root_ptr () call ifile_final (ifile) write (u, "(A)") write (u, "(A)") "* Initialize process expr" write (u, "(A)") call expr%setup_vars (1000._default) call expr%var_list%append_real (var_str ("tolerance"), 0._default) call expr%link_var_list (model%get_var_list_ptr ()) call expr_factory%init (pn_cuts) call expr%setup_selection (expr_factory) call expr_factory%init (pn_scale) call expr%setup_scale (expr_factory) call expr_factory%init (pn_fac_scale) call expr%setup_fac_scale (expr_factory) call expr_factory%init (pn_ren_scale) call expr%setup_ren_scale (expr_factory) call expr_factory%init (pn_weight) call expr%setup_weight (expr_factory) call write_separator (u) call expr%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Fill subevt and evaluate expressions" write (u, "(A)") call subevt_init (expr%subevt_t, 6) E = 500._default Ex = 400._default m = 125._default pdg = 25 p(1) = vector4_moving (E, sqrt (E**2 - m**2), 3) p(2) = vector4_moving (E, -sqrt (E**2 - m**2), 3) p(3) = vector4_moving (Ex, sqrt (Ex**2 - m**2), 3) p(4) = vector4_moving (Ex, -sqrt (Ex**2 - m**2), 3) p(5) = vector4_moving (Ex, sqrt (Ex**2 - m**2), 1) p(6) = vector4_moving (Ex, -sqrt (Ex**2 - m**2), 1) call expr%reset_contents () do i = 1, 2 call subevt_set_beam (expr%subevt_t, i, pdg, p(i), m**2) end do do i = 3, 4 call subevt_set_incoming (expr%subevt_t, i, pdg, p(i), m**2) end do do i = 5, 6 call subevt_set_outgoing (expr%subevt_t, i, pdg, p(i), m**2) end do expr%sqrts_hat = subevt_get_sqrts_hat (expr%subevt_t) expr%n_in = 2 expr%n_out = 2 expr%n_tot = 4 expr%subevt_filled = .true. call expr%evaluate (passed, scale, fac_scale, ren_scale, weight) write (u, "(A,L1)") "Event has passed = ", passed write (u, "(A," // FMT_12 // ")") "Scale = ", scale write (u, "(A," // FMT_12 // ")") "Factorization scale = ", fac_scale write (u, "(A," // FMT_12 // ")") "Renormalization scale = ", ren_scale write (u, "(A," // FMT_12 // ")") "Weight = ", weight write (u, "(A)") call write_separator (u) call expr%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call expr%final () call model%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: subevt_expr_1" end subroutine subevt_expr_1 @ %def subevt_expr_1 @ \subsubsection{Parton-event expressions} <>= call test (subevt_expr_2, "subevt_expr_2", & "parton-event expressions", & u, results) <>= public :: subevt_expr_2 <>= subroutine subevt_expr_2 (u) integer, intent(in) :: u type(string_t) :: expr_text type(ifile_t) :: ifile type(stream_t) :: stream type(parse_tree_t) :: pt_selection type(parse_tree_t) :: pt_reweight, pt_analysis type(parse_node_t), pointer :: pn_selection type(parse_node_t), pointer :: pn_reweight, pn_analysis type(os_data_t) :: os_data type(model_t), target :: model type(eval_tree_factory_t) :: expr_factory type(event_expr_t), target :: expr real(default) :: E, Ex, m type(vector4_t), dimension(6) :: p integer :: i, pdg logical :: passed real(default) :: reweight logical :: analysis_flag write (u, "(A)") "* Test output: subevt_expr_2" write (u, "(A)") "* Purpose: Set up a subevt and associated & &process-specific expressions" write (u, "(A)") call syntax_pexpr_init () call syntax_model_file_init () call os_data%init () call model%read (var_str ("Test.mdl"), os_data) write (u, "(A)") "* Expression texts" write (u, "(A)") expr_text = "all Pt > 100 [s]" write (u, "(A,A)") "selection = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_lexpr (pt_selection, stream, .true.) call stream_final (stream) pn_selection => pt_selection%get_root_ptr () expr_text = "n_tot - n_in - n_out" write (u, "(A,A)") "reweight = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_reweight, stream, .true.) call stream_final (stream) pn_reweight => pt_reweight%get_root_ptr () expr_text = "true" write (u, "(A,A)") "analysis = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_lexpr (pt_analysis, stream, .true.) call stream_final (stream) pn_analysis => pt_analysis%get_root_ptr () call ifile_final (ifile) write (u, "(A)") write (u, "(A)") "* Initialize process expr" write (u, "(A)") call expr%setup_vars (1000._default) call expr%link_var_list (model%get_var_list_ptr ()) call expr%var_list%append_real (var_str ("tolerance"), 0._default) call expr_factory%init (pn_selection) call expr%setup_selection (expr_factory) call expr_factory%init (pn_analysis) call expr%setup_analysis (expr_factory) call expr_factory%init (pn_reweight) call expr%setup_reweight (expr_factory) call write_separator (u) call expr%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Fill subevt and evaluate expressions" write (u, "(A)") call subevt_init (expr%subevt_t, 6) E = 500._default Ex = 400._default m = 125._default pdg = 25 p(1) = vector4_moving (E, sqrt (E**2 - m**2), 3) p(2) = vector4_moving (E, -sqrt (E**2 - m**2), 3) p(3) = vector4_moving (Ex, sqrt (Ex**2 - m**2), 3) p(4) = vector4_moving (Ex, -sqrt (Ex**2 - m**2), 3) p(5) = vector4_moving (Ex, sqrt (Ex**2 - m**2), 1) p(6) = vector4_moving (Ex, -sqrt (Ex**2 - m**2), 1) call expr%reset_contents () do i = 1, 2 call subevt_set_beam (expr%subevt_t, i, pdg, p(i), m**2) end do do i = 3, 4 call subevt_set_incoming (expr%subevt_t, i, pdg, p(i), m**2) end do do i = 5, 6 call subevt_set_outgoing (expr%subevt_t, i, pdg, p(i), m**2) end do expr%sqrts_hat = subevt_get_sqrts_hat (expr%subevt_t) expr%n_in = 2 expr%n_out = 2 expr%n_tot = 4 expr%subevt_filled = .true. call expr%evaluate (passed, reweight, analysis_flag) write (u, "(A,L1)") "Event has passed = ", passed write (u, "(A," // FMT_12 // ")") "Reweighting factor = ", reweight write (u, "(A,L1)") "Analysis flag = ", analysis_flag write (u, "(A)") call write_separator (u) call expr%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call expr%final () call model%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: subevt_expr_2" end subroutine subevt_expr_2 @ %def subevt_expr_2 @ \subsubsection{Processes: handle partonic cuts} Initialize a process and process instance, choose a sampling point and fill the process instance, evaluating a given cut configuration. We use the same trivial process as for the previous test. All momentum and state dependence is trivial, so we just test basic functionality. <>= call test (processes_5, "processes_5", & "handle cuts (partonic event)", & u, results) <>= public :: processes_5 <>= subroutine processes_5 (u) integer, intent(in) :: u type(string_t) :: cut_expr_text type(ifile_t) :: ifile type(stream_t) :: stream type(parse_tree_t) :: parse_tree type(eval_tree_factory_t) :: expr_factory type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), pointer :: model_tmp type(model_t), pointer :: model type(var_list_t), target :: var_list type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t), allocatable, target :: process_instance write (u, "(A)") "* Test output: processes_5" write (u, "(A)") "* Purpose: create a process & &and fill a process instance" write (u, "(A)") write (u, "(A)") "* Prepare a cut expression" write (u, "(A)") call syntax_pexpr_init () cut_expr_text = "all Pt > 100 [s]" call ifile_append (ifile, cut_expr_text) call stream_init (stream, ifile) call parse_tree_init_lexpr (parse_tree, stream, .true.) write (u, "(A)") "* Build and initialize a test process" write (u, "(A)") libname = "processes5" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call syntax_model_file_init () allocate (model_tmp) call model_tmp%read (var_str ("Test.mdl"), os_data) call var_list%init_snapshot (model_tmp%get_var_list_ptr ()) model => model_tmp call reset_interaction_counter () call var_list%append_real (var_str ("tolerance"), 0._default) call var_list%append_log (var_str ("?alphas_is_fixed"), .true.) call var_list%append_int (var_str ("seed"), 0) allocate (process) call process%init (procname, lib, os_data, model, var_list) call var_list%final () allocate (phs_test_config_t :: phs_config_template) call process%setup_test_cores () call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_empty) write (u, "(A)") "* Complete process initialization and set cuts" write (u, "(A)") call process%setup_terms () call expr_factory%init (parse_tree%get_root_ptr ()) call process%set_cuts (expr_factory) call process%write (.false., u, & show_var_list=.true., show_expressions=.true., show_os_data=.false.) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) write (u, "(A)") write (u, "(A)") "* Inject a set of random numbers" write (u, "(A)") call process_instance%choose_mci (1) call process_instance%set_mcpar ([0._default, 0._default]) write (u, "(A)") write (u, "(A)") "* Set up kinematics and subevt, check cuts (should fail)" write (u, "(A)") call process_instance%select_channel (1) call process_instance%compute_seed_kinematics () call process_instance%compute_hard_kinematics () call process_instance%compute_eff_kinematics () call process_instance%evaluate_expressions () call process_instance%compute_other_channels () call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for another set (should succeed)" write (u, "(A)") call process_instance%reset () call process_instance%set_mcpar ([0.5_default, 0.125_default]) call process_instance%select_channel (1) call process_instance%compute_seed_kinematics () call process_instance%compute_hard_kinematics () call process_instance%compute_eff_kinematics () call process_instance%evaluate_expressions () call process_instance%compute_other_channels () call process_instance%evaluate_trace () call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for another set using convenience procedure & &(failure)" write (u, "(A)") call process_instance%evaluate_sqme (1, [0.0_default, 0.2_default]) call process_instance%write_header (u) write (u, "(A)") write (u, "(A)") "* Evaluate for another set using convenience procedure & &(success)" write (u, "(A)") call process_instance%evaluate_sqme (1, [0.1_default, 0.2_default]) call process_instance%write_header (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call parse_tree_final (parse_tree) call stream_final (stream) call ifile_final (ifile) call syntax_pexpr_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_5" end subroutine processes_5 @ %def processes_5 @ Trivial for testing: do not allocate the MCI record. <>= subroutine dispatch_mci_empty (mci, var_list, process_id, is_nlo) class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo end subroutine dispatch_mci_empty @ %def dispatch_mci_empty @ \subsubsection{Processes: scales and such} Initialize a process and process instance, choose a sampling point and fill the process instance, evaluating a given cut configuration. We use the same trivial process as for the previous test. All momentum and state dependence is trivial, so we just test basic functionality. <>= call test (processes_6, "processes_6", & "handle scales and weight (partonic event)", & u, results) <>= public :: processes_6 <>= subroutine processes_6 (u) integer, intent(in) :: u type(string_t) :: expr_text type(ifile_t) :: ifile type(stream_t) :: stream type(parse_tree_t) :: pt_scale, pt_fac_scale, pt_ren_scale, pt_weight type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), pointer :: model_tmp type(model_t), pointer :: model type(var_list_t), target :: var_list type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t), allocatable, target :: process_instance type(eval_tree_factory_t) :: expr_factory write (u, "(A)") "* Test output: processes_6" write (u, "(A)") "* Purpose: create a process & &and fill a process instance" write (u, "(A)") write (u, "(A)") "* Prepare expressions" write (u, "(A)") call syntax_pexpr_init () expr_text = "sqrts - 100 GeV" write (u, "(A,A)") "scale = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_scale, stream, .true.) call stream_final (stream) expr_text = "sqrts_hat" write (u, "(A,A)") "fac_scale = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_fac_scale, stream, .true.) call stream_final (stream) expr_text = "eval sqrt (M2) [collect [s]]" write (u, "(A,A)") "ren_scale = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_ren_scale, stream, .true.) call stream_final (stream) expr_text = "n_tot * n_in * n_out * (eval Phi / pi [s])" write (u, "(A,A)") "weight = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_weight, stream, .true.) call stream_final (stream) call ifile_final (ifile) write (u, "(A)") write (u, "(A)") "* Build and initialize a test process" write (u, "(A)") libname = "processes4" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call syntax_model_file_init () allocate (model_tmp) call model_tmp%read (var_str ("Test.mdl"), os_data) call var_list%init_snapshot (model_tmp%get_var_list_ptr ()) model => model_tmp call var_list%append_log (var_str ("?alphas_is_fixed"), .true.) call var_list%append_int (var_str ("seed"), 0) call reset_interaction_counter () allocate (process) call process%init (procname, lib, os_data, model, var_list) call var_list%final () call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_empty) write (u, "(A)") "* Complete process initialization and set cuts" write (u, "(A)") call process%setup_terms () call expr_factory%init (pt_scale%get_root_ptr ()) call process%set_scale (expr_factory) call expr_factory%init (pt_fac_scale%get_root_ptr ()) call process%set_fac_scale (expr_factory) call expr_factory%init (pt_ren_scale%get_root_ptr ()) call process%set_ren_scale (expr_factory) call expr_factory%init (pt_weight%get_root_ptr ()) call process%set_weight (expr_factory) call process%write (.false., u, show_expressions=.true.) write (u, "(A)") write (u, "(A)") "* Create a process instance and evaluate" write (u, "(A)") allocate (process_instance) call process_instance%init (process) call process_instance%choose_mci (1) call process_instance%evaluate_sqme (1, [0.5_default, 0.125_default]) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call parse_tree_final (pt_scale) call parse_tree_final (pt_fac_scale) call parse_tree_final (pt_ren_scale) call parse_tree_final (pt_weight) call syntax_pexpr_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_6" end subroutine processes_6 @ %def processes_6 @ \subsubsection{Event expressions} After generating an event, fill the [[subevt]] and evaluate expressions for selection, reweighting, and analysis. <>= call test (events_3, "events_3", & "expression evaluation", & u, results) <>= public :: events_3 <>= subroutine events_3 (u) use processes_ut, only: prepare_test_process, cleanup_test_process integer, intent(in) :: u type(string_t) :: expr_text type(ifile_t) :: ifile type(stream_t) :: stream type(parse_tree_t) :: pt_selection, pt_reweight, pt_analysis type(eval_tree_factory_t) :: expr_factory type(event_t), allocatable, target :: event type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance type(os_data_t) :: os_data type(model_t), pointer :: model type(var_list_t), target :: var_list write (u, "(A)") "* Test output: events_3" write (u, "(A)") "* Purpose: generate an event and evaluate expressions" write (u, "(A)") call syntax_pexpr_init () write (u, "(A)") "* Expression texts" write (u, "(A)") expr_text = "all Pt > 100 [s]" write (u, "(A,A)") "selection = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_lexpr (pt_selection, stream, .true.) call stream_final (stream) expr_text = "1 + sqrts_hat / sqrts" write (u, "(A,A)") "reweight = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_expr (pt_reweight, stream, .true.) call stream_final (stream) expr_text = "true" write (u, "(A,A)") "analysis = ", char (expr_text) call ifile_clear (ifile) call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call parse_tree_init_lexpr (pt_analysis, stream, .true.) call stream_final (stream) call ifile_final (ifile) write (u, "(A)") write (u, "(A)") "* Initialize test process event" call os_data%init () call syntax_model_file_init () allocate (model) call model%read (var_str ("Test.mdl"), os_data) call var_list%init_snapshot (model%get_var_list_ptr ()) call var_list%append_log (var_str ("?alphas_is_fixed"), .true.) call var_list%append_int (var_str ("seed"), 0) allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model, var_list) call var_list%final () call process_instance%setup_event_data () write (u, "(A)") write (u, "(A)") "* Initialize event object and set expressions" allocate (event) call event%basic_init () call expr_factory%init (pt_selection%get_root_ptr ()) call event%set_selection (expr_factory) call expr_factory%init (pt_reweight%get_root_ptr ()) call event%set_reweight (expr_factory) call expr_factory%init (pt_analysis%get_root_ptr ()) call event%set_analysis (expr_factory) call event%connect (process_instance, process%get_model_ptr ()) call event%expr%var_list%append_real (var_str ("tolerance"), 0._default) call event%setup_expressions () write (u, "(A)") write (u, "(A)") "* Generate test process event" call process_instance%generate_weighted_event (1) write (u, "(A)") write (u, "(A)") "* Fill event object and evaluate expressions" write (u, "(A)") call event%generate (1, [0.4_default, 0.4_default]) call event%set_index (42) call event%evaluate_expressions () call event%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call event%final () deallocate (event) call cleanup_test_process (process, process_instance) deallocate (process_instance) deallocate (process) call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: events_3" end subroutine events_3 @ %def events_3 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Top Level} The top level consists of \begin{description} \item[commands] Defines generic command-list and command objects, and all specific implementations. Each command type provides a specific functionality. Together with the modules that provide expressions and variables, this module defines the Sindarin language. \item[whizard] This module interprets streams of various kind in terms of the command language. It also contains the unit-test feature. We also define the externally visible procedures here, for the \whizard\ as a library. \item[main] The driver for \whizard\ as a stand-alone program. Contains the command-line interpreter. \item[whizard\_c\_interface] Alternative top-level procedures, for use in the context of a C-compatible caller program. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Commands} This module defines the command language of the main input file. <<[[commands.f90]]>>= <> module commands <> <> use io_units use string_utils, only: lower_case, split_string, str use format_utils, only: write_indent use format_defs, only: FMT_14, FMT_19 use diagnostics use physics_defs use sorting use sf_lhapdf, only: lhapdf_global_reset use os_interface use ifiles use lexers use syntax_rules use parser use analysis use pdg_arrays use variables, only: var_list_t, V_NONE, V_LOG, V_INT, V_REAL, V_CMPLX, V_STR, V_PDG use observables, only: var_list_check_observable use observables, only: var_list_check_result_var use eval_trees use models use auto_components use flavors use polarizations use particle_specifiers use process_libraries use process use instances use prclib_stacks use slha_interface use user_files use eio_data use rt_data use process_configurations use compilations, only: compile_library, compile_executable use integrations, only: integrate_process use restricted_subprocesses, only: get_libname_res use restricted_subprocesses, only: spawn_resonant_subprocess_libraries use event_streams use simulations use radiation_generator <> <> <> <> <> <> <> contains <> end module commands @ %def commands @ \subsection{The command type} The command type is a generic type that holds any command, compiled for execution. Each command may come with its own local environment. The command list that determines this environment is allocated as [[options]], if necessary. (It has to be allocated as a pointer because the type definition is recursive.) The local environment is available as a pointer which either points to the global environment, or is explicitly allocated and initialized. <>= type, abstract :: command_t type(parse_node_t), pointer :: pn => null () class(command_t), pointer :: next => null () type(parse_node_t), pointer :: pn_opt => null () type(command_list_t), pointer :: options => null () type(rt_data_t), pointer :: local => null () contains <> end type command_t @ %def command_t @ Finalizer: If there is an option list, finalize the option list and deallocate. If not, the local environment is just a pointer. <>= procedure :: final => command_final <>= recursive subroutine command_final (cmd) class(command_t), intent(inout) :: cmd if (associated (cmd%options)) then call cmd%options%final () deallocate (cmd%options) call cmd%local%local_final () deallocate (cmd%local) else cmd%local => null () end if end subroutine command_final @ %def command_final @ Allocate a command with the appropriate concrete type. Store the parse node pointer in the command object, so we can reference to it when compiling. <>= subroutine dispatch_command (command, pn) class(command_t), intent(inout), pointer :: command type(parse_node_t), intent(in), target :: pn select case (char (parse_node_get_rule_key (pn))) case ("cmd_model") allocate (cmd_model_t :: command) case ("cmd_library") allocate (cmd_library_t :: command) case ("cmd_process") allocate (cmd_process_t :: command) case ("cmd_nlo") allocate (cmd_nlo_t :: command) case ("cmd_compile") allocate (cmd_compile_t :: command) case ("cmd_exec") allocate (cmd_exec_t :: command) case ("cmd_num", "cmd_complex", "cmd_real", "cmd_int", & "cmd_log_decl", "cmd_log", "cmd_string", "cmd_string_decl", & "cmd_alias", "cmd_result") allocate (cmd_var_t :: command) case ("cmd_slha") allocate (cmd_slha_t :: command) case ("cmd_show") allocate (cmd_show_t :: command) case ("cmd_clear") allocate (cmd_clear_t :: command) case ("cmd_expect") allocate (cmd_expect_t :: command) case ("cmd_beams") allocate (cmd_beams_t :: command) case ("cmd_beams_pol_density") allocate (cmd_beams_pol_density_t :: command) case ("cmd_beams_pol_fraction") allocate (cmd_beams_pol_fraction_t :: command) case ("cmd_beams_momentum") allocate (cmd_beams_momentum_t :: command) case ("cmd_beams_theta") allocate (cmd_beams_theta_t :: command) case ("cmd_beams_phi") allocate (cmd_beams_phi_t :: command) case ("cmd_cuts") allocate (cmd_cuts_t :: command) case ("cmd_scale") allocate (cmd_scale_t :: command) case ("cmd_fac_scale") allocate (cmd_fac_scale_t :: command) case ("cmd_ren_scale") allocate (cmd_ren_scale_t :: command) case ("cmd_weight") allocate (cmd_weight_t :: command) case ("cmd_selection") allocate (cmd_selection_t :: command) case ("cmd_reweight") allocate (cmd_reweight_t :: command) case ("cmd_iterations") allocate (cmd_iterations_t :: command) case ("cmd_integrate") allocate (cmd_integrate_t :: command) case ("cmd_observable") allocate (cmd_observable_t :: command) case ("cmd_histogram") allocate (cmd_histogram_t :: command) case ("cmd_plot") allocate (cmd_plot_t :: command) case ("cmd_graph") allocate (cmd_graph_t :: command) case ("cmd_record") allocate (cmd_record_t :: command) case ("cmd_analysis") allocate (cmd_analysis_t :: command) case ("cmd_alt_setup") allocate (cmd_alt_setup_t :: command) case ("cmd_unstable") allocate (cmd_unstable_t :: command) case ("cmd_stable") allocate (cmd_stable_t :: command) case ("cmd_polarized") allocate (cmd_polarized_t :: command) case ("cmd_unpolarized") allocate (cmd_unpolarized_t :: command) case ("cmd_sample_format") allocate (cmd_sample_format_t :: command) case ("cmd_simulate") allocate (cmd_simulate_t :: command) case ("cmd_rescan") allocate (cmd_rescan_t :: command) case ("cmd_write_analysis") allocate (cmd_write_analysis_t :: command) case ("cmd_compile_analysis") allocate (cmd_compile_analysis_t :: command) case ("cmd_open_out") allocate (cmd_open_out_t :: command) case ("cmd_close_out") allocate (cmd_close_out_t :: command) case ("cmd_printf") allocate (cmd_printf_t :: command) case ("cmd_scan") allocate (cmd_scan_t :: command) case ("cmd_if") allocate (cmd_if_t :: command) case ("cmd_include") allocate (cmd_include_t :: command) case ("cmd_export") allocate (cmd_export_t :: command) case ("cmd_quit") allocate (cmd_quit_t :: command) case default print *, char (parse_node_get_rule_key (pn)) call msg_bug ("Command not implemented") end select command%pn => pn end subroutine dispatch_command @ %def dispatch_command @ Output. We allow for indentation so we can display a command tree. <>= procedure (command_write), deferred :: write <>= abstract interface subroutine command_write (cmd, unit, indent) import class(command_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent end subroutine command_write end interface @ %def command_write @ Compile a command. The command type is already fixed, so this is a deferred type-bound procedure. <>= procedure (command_compile), deferred :: compile <>= abstract interface subroutine command_compile (cmd, global) import class(command_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global end subroutine command_compile end interface @ %def command_compile @ Execute a command. This will use and/or modify the runtime data set. If the [[quit]] flag is set, the caller should terminate command execution. <>= procedure (command_execute), deferred :: execute <>= abstract interface subroutine command_execute (cmd, global) import class(command_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global end subroutine command_execute end interface @ %def command_execute @ \subsection{Options} The [[options]] command list is allocated, initialized, and executed, if the command is associated with an option text in curly braces. If present, a separate local runtime data set [[local]] will be allocated and initialized; otherwise, [[local]] becomes a pointer to the global dataset. For output, we indent the options list. <>= procedure :: write_options => command_write_options <>= recursive subroutine command_write_options (cmd, unit, indent) class(command_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: ind ind = 1; if (present (indent)) ind = indent + 1 if (associated (cmd%options)) call cmd%options%write (unit, ind) end subroutine command_write_options @ %def command_write_options @ Compile the options list, if any. This implies initialization of the local environment. Should be done once the [[pn_opt]] node has been assigned (if applicable), but before the actual command compilation. <>= procedure :: compile_options => command_compile_options <>= recursive subroutine command_compile_options (cmd, global) class(command_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global if (associated (cmd%pn_opt)) then allocate (cmd%local) call cmd%local%local_init (global) call global%copy_globals (cmd%local) allocate (cmd%options) call cmd%options%compile (cmd%pn_opt, cmd%local) call global%restore_globals (cmd%local) call cmd%local%deactivate () else cmd%local => global end if end subroutine command_compile_options @ %def command_compile_options @ Execute options. First prepare the local environment, then execute the command list. <>= procedure :: execute_options => cmd_execute_options <>= recursive subroutine cmd_execute_options (cmd, global) class(command_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global if (associated (cmd%options)) then call cmd%local%activate () call cmd%options%execute (cmd%local) end if end subroutine cmd_execute_options @ %def cmd_execute_options @ This must be called after the parent command has been executed, to undo temporary modifications to the environment. Note that some modifications to [[global]] can become permanent. <>= procedure :: reset_options => cmd_reset_options <>= subroutine cmd_reset_options (cmd, global) class(command_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global if (associated (cmd%options)) then call cmd%local%deactivate (global) end if end subroutine cmd_reset_options @ %def cmd_reset_options @ \subsection{Specific command types} \subsubsection{Model configuration} The command declares a model, looks for the specified file and loads it. <>= type, extends (command_t) :: cmd_model_t private type(string_t) :: name type(string_t) :: scheme logical :: ufo_model = .false. logical :: ufo_path_set = .false. type(string_t) :: ufo_path contains <> end type cmd_model_t @ %def cmd_model_t @ Output <>= procedure :: write => cmd_model_write <>= subroutine cmd_model_write (cmd, unit, indent) class(cmd_model_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,1x,'""',A,'""')", advance="no") "model =", char (cmd%name) if (cmd%ufo_model) then if (cmd%ufo_path_set) then write (u, "(1x,A,A,A)") "(ufo (", char (cmd%ufo_path), "))" else write (u, "(1x,A)") "(ufo)" end if else if (cmd%scheme /= "") then write (u, "(1x,'(',A,')')") char (cmd%scheme) else write (u, *) end if end subroutine cmd_model_write @ %def cmd_model_write @ Compile. Get the model name and read the model from file, so it is readily available when the command list is executed. If the model has a scheme argument, take this into account. Assign the model pointer in the [[global]] record, so it can be used for (read-only) variable lookup while compiling further commands. <>= procedure :: compile => cmd_model_compile <>= subroutine cmd_model_compile (cmd, global) class(cmd_model_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_name, pn_arg, pn_scheme type(parse_node_t), pointer :: pn_ufo_arg, pn_path type(model_t), pointer :: model type(string_t) :: scheme pn_name => cmd%pn%get_sub_ptr (3) pn_arg => pn_name%get_next_ptr () if (associated (pn_arg)) then pn_scheme => pn_arg%get_sub_ptr () else pn_scheme => null () end if cmd%name = pn_name%get_string () if (associated (pn_scheme)) then select case (char (pn_scheme%get_rule_key ())) case ("ufo_spec") cmd%ufo_model = .true. pn_ufo_arg => pn_scheme%get_sub_ptr (2) if (associated (pn_ufo_arg)) then pn_path => pn_ufo_arg%get_sub_ptr () cmd%ufo_path_set = .true. cmd%ufo_path = pn_path%get_string () end if case default scheme = pn_scheme%get_string () select case (char (lower_case (scheme))) case ("ufo"); cmd%ufo_model = .true. case default; cmd%scheme = scheme end select end select if (cmd%ufo_model) then if (cmd%ufo_path_set) then call preload_ufo_model (model, cmd%name, cmd%ufo_path) else call preload_ufo_model (model, cmd%name) end if else call preload_model (model, cmd%name, cmd%scheme) end if else cmd%scheme = "" call preload_model (model, cmd%name) end if global%model => model if (associated (global%model)) then call global%model%link_var_list (global%var_list) end if contains subroutine preload_model (model, name, scheme) type(model_t), pointer, intent(out) :: model type(string_t), intent(in) :: name type(string_t), intent(in), optional :: scheme model => null () if (associated (global%model)) then if (global%model%matches (name, scheme)) then model => global%model end if end if if (.not. associated (model)) then if (global%model_list%model_exists (name, scheme)) then model => global%model_list%get_model_ptr (name, scheme) else call global%read_model (name, model, scheme) end if end if end subroutine preload_model subroutine preload_ufo_model (model, name, ufo_path) type(model_t), pointer, intent(out) :: model type(string_t), intent(in) :: name type(string_t), intent(in), optional :: ufo_path model => null () if (associated (global%model)) then if (global%model%matches (name, ufo=.true., ufo_path=ufo_path)) then model => global%model end if end if if (.not. associated (model)) then if (global%model_list%model_exists (name, & ufo=.true., ufo_path=ufo_path)) then model => global%model_list%get_model_ptr (name, & ufo=.true., ufo_path=ufo_path) else call global%read_ufo_model (name, model, ufo_path=ufo_path) end if end if end subroutine preload_ufo_model end subroutine cmd_model_compile @ %def cmd_model_compile @ Execute: Insert a pointer into the global data record and reassign the variable list. <>= procedure :: execute => cmd_model_execute <>= subroutine cmd_model_execute (cmd, global) class(cmd_model_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global if (cmd%ufo_model) then if (cmd%ufo_path_set) then call global%select_model (cmd%name, ufo=.true., ufo_path=cmd%ufo_path) else call global%select_model (cmd%name, ufo=.true.) end if else if (cmd%scheme /= "") then call global%select_model (cmd%name, cmd%scheme) else call global%select_model (cmd%name) end if if (.not. associated (global%model)) & call msg_fatal ("Switching to model '" & // char (cmd%name) // "': model not found") end subroutine cmd_model_execute @ %def cmd_model_execute @ \subsubsection{Library configuration} We configure a process library that should hold the subsequently defined processes. If the referenced library exists already, just make it the currently active one. <>= type, extends (command_t) :: cmd_library_t private type(string_t) :: name contains <> end type cmd_library_t @ %def cmd_library_t @ Output. <>= procedure :: write => cmd_library_write <>= subroutine cmd_library_write (cmd, unit, indent) class(cmd_library_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit) call write_indent (u, indent) write (u, "(1x,A,1x,'""',A,'""')") "library =", char (cmd%name) end subroutine cmd_library_write @ %def cmd_library_write @ Compile. Get the library name. <>= procedure :: compile => cmd_library_compile <>= subroutine cmd_library_compile (cmd, global) class(cmd_library_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_name pn_name => parse_node_get_sub_ptr (cmd%pn, 3) cmd%name = parse_node_get_string (pn_name) end subroutine cmd_library_compile @ %def cmd_library_compile @ Execute: Initialize a new library and push it on the library stack (if it does not yet exist). Insert a pointer to the library into the global data record. Then, try to load the library unless the [[rebuild]] flag is set. <>= procedure :: execute => cmd_library_execute <>= subroutine cmd_library_execute (cmd, global) class(cmd_library_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib logical :: rebuild_library lib => global%prclib_stack%get_library_ptr (cmd%name) rebuild_library = & global%var_list%get_lval (var_str ("?rebuild_library")) if (.not. (associated (lib))) then allocate (lib_entry) call lib_entry%init (cmd%name) lib => lib_entry%process_library_t call global%add_prclib (lib_entry) else call global%update_prclib (lib) end if if (associated (lib) .and. .not. rebuild_library) then call lib%update_status (global%os_data) end if end subroutine cmd_library_execute @ %def cmd_library_execute @ \subsubsection{Process configuration} We define a process-configuration command as a specific type. The incoming and outgoing particles are given evaluation-trees which we transform to PDG-code arrays. For transferring to \oMega, they are reconverted to strings. For the incoming particles, we store parse nodes individually. We do not yet resolve the outgoing state, so we store just a single parse node. This also includes the choice of method for the corresponding process: [[omega]] for \oMega\ matrix elements as Fortran code, [[ovm]] for \oMega\ matrix elements as a bytecode virtual machine, [[test]] for special processes, [[unit_test]] for internal test matrix elements generated by \whizard, [[template]] and [[template_unity]] for test matrix elements generated by \whizard\ as Fortran code similar to the \oMega\ code. If the one-loop program (OLP) \gosam\ is linked, also matrix elements from there (at leading and next-to-leading order) can be generated via [[gosam]]. <>= type, extends (command_t) :: cmd_process_t private type(string_t) :: id integer :: n_in = 0 type(parse_node_p), dimension(:), allocatable :: pn_pdg_in type(parse_node_t), pointer :: pn_out => null () contains <> end type cmd_process_t @ %def cmd_process_t @ Output. The particle expressions are not resolved, so we just list the number of incoming particles. <>= procedure :: write => cmd_process_write <>= subroutine cmd_process_write (cmd, unit, indent) class(cmd_process_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,A,A,I0,A)") "process: ", char (cmd%id), " (", & size (cmd%pn_pdg_in), " -> X)" call cmd%write_options (u, indent) end subroutine cmd_process_write @ %def cmd_process_write @ Compile. Find and assign the parse nodes. <>= procedure :: compile => cmd_process_compile <>= subroutine cmd_process_compile (cmd, global) class(cmd_process_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_id, pn_in, pn_codes integer :: i pn_id => parse_node_get_sub_ptr (cmd%pn, 2) pn_in => parse_node_get_next_ptr (pn_id, 2) cmd%pn_out => parse_node_get_next_ptr (pn_in, 2) cmd%pn_opt => parse_node_get_next_ptr (cmd%pn_out) call cmd%compile_options (global) cmd%id = parse_node_get_string (pn_id) cmd%n_in = parse_node_get_n_sub (pn_in) pn_codes => parse_node_get_sub_ptr (pn_in) allocate (cmd%pn_pdg_in (cmd%n_in)) do i = 1, cmd%n_in cmd%pn_pdg_in(i)%ptr => pn_codes pn_codes => parse_node_get_next_ptr (pn_codes) end do end subroutine cmd_process_compile @ %def cmd_process_compile @ Command execution. Evaluate the subevents, transform PDG codes into strings, and add the current process configuration to the process library. The initial state will be unique (one or two particles). For the final state, we allow for expressions. The expressions will be expanded until we have a sum of final states. Each distinct final state will get its own process component. To identify equivalent final states, we transform the final state into an array of PDG codes, which we sort and compare. If a particle entry is actually a PDG array, only the first entry in the array is used for the comparison. The user should make sure that there is no overlap between different particles or arrays which would make the expansion ambiguous. There are two possibilities that a process contains more than component: by an explicit component statement by the user for inclusive processes, or by having one process at NLO level. The first option is determined in the routine [[scan_components]], and determines [[n_components]]. <>= procedure :: execute => cmd_process_execute <>= subroutine cmd_process_execute (cmd, global) class(cmd_process_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(pdg_array_t) :: pdg_in, pdg_out type(pdg_array_t), dimension(:), allocatable :: pdg_out_tab type(string_t), dimension(:), allocatable :: prt_in type(string_t) :: prt_out, prt_out1 type(process_configuration_t) :: prc_config type(prt_expr_t) :: prt_expr_out type(prt_spec_t), dimension(:), allocatable :: prt_spec_in type(prt_spec_t), dimension(:), allocatable :: prt_spec_out type(var_list_t), pointer :: var_list integer, dimension(:), allocatable :: pdg integer, dimension(:), allocatable :: i_term integer, dimension(:), allocatable :: nlo_comp integer :: i, j, n_in, n_out, n_terms, n_components logical :: nlo_fixed_order logical :: qcd_corr, qed_corr type(string_t), dimension(:), allocatable :: prt_in_nlo, prt_out_nlo type(radiation_generator_t) :: radiation_generator type(pdg_list_t) :: pl_in, pl_out, pl_excluded_gauge_splittings type(string_t) :: method, born_me_method, loop_me_method, & correlation_me_method, real_tree_me_method, dglap_me_method integer, dimension(:), allocatable :: i_list logical :: use_real_finite logical :: gks_active logical :: initial_state_colored integer :: comp_mult integer :: gks_multiplicity integer :: n_components_init integer :: alpha_power, alphas_power logical :: requires_soft_mismatch, requires_dglap_remnants call msg_debug (D_CORE, "cmd_process_execute") var_list => cmd%local%get_var_list_ptr () n_in = size (cmd%pn_pdg_in) allocate (prt_in (n_in), prt_spec_in (n_in)) do i = 1, n_in pdg_in = & eval_pdg_array (cmd%pn_pdg_in(i)%ptr, var_list) prt_in(i) = make_flavor_string (pdg_in, cmd%local%model) prt_spec_in(i) = new_prt_spec (prt_in(i)) end do call compile_prt_expr & (prt_expr_out, cmd%pn_out, var_list, cmd%local%model) call prt_expr_out%expand () call scan_components () allocate (nlo_comp (n_components)) nlo_fixed_order = cmd%local%nlo_fixed_order gks_multiplicity = var_list%get_ival (var_str ('gks_multiplicity')) gks_active = gks_multiplicity > 2 call check_for_nlo_corrections () method = var_list%get_sval (var_str ("$method")) born_me_method = var_list%get_sval (var_str ("$born_me_method")) if (born_me_method == var_str ("")) born_me_method = method use_real_finite = var_list%get_lval (var_str ('?nlo_use_real_partition')) if (nlo_fixed_order) then real_tree_me_method = & var_list%get_sval (var_str ("$real_tree_me_method")) if (real_tree_me_method == var_str ("")) & real_tree_me_method = method loop_me_method = var_list%get_sval (var_str ("$loop_me_method")) if (loop_me_method == var_str ("")) & loop_me_method = method correlation_me_method = & var_list%get_sval (var_str ("$correlation_me_method")) if (correlation_me_method == var_str ("")) & correlation_me_method = method dglap_me_method = var_list%get_sval (var_str ("$dglap_me_method")) if (dglap_me_method == var_str ("")) & dglap_me_method = method call check_nlo_options (cmd%local) end if call determine_needed_components () call prc_config%init (cmd%id, n_in, n_components_init, & cmd%local%model, cmd%local%var_list, & nlo_process = nlo_fixed_order) alpha_power = var_list%get_ival (var_str ("alpha_power")) alphas_power = var_list%get_ival (var_str ("alphas_power")) call prc_config%set_coupling_powers (alpha_power, alphas_power) call setup_components () call prc_config%record (cmd%local) contains <> end subroutine cmd_process_execute @ %def cmd_process_execute @ <>= elemental function is_threshold (method) logical :: is_threshold type(string_t), intent(in) :: method is_threshold = method == var_str ("threshold") end function is_threshold subroutine check_threshold_consistency () if (nlo_fixed_order .and. is_threshold (born_me_method)) then if (.not. (is_threshold (real_tree_me_method) .and. is_threshold (loop_me_method) & .and. is_threshold (correlation_me_method))) then print *, 'born: ', char (born_me_method) print *, 'real: ', char (real_tree_me_method) print *, 'loop: ', char (loop_me_method) print *, 'correlation: ', char (correlation_me_method) call msg_fatal ("Inconsistent methods: All components need to be threshold") end if end if end subroutine check_threshold_consistency @ %def check_threshold_consistency <>= subroutine check_for_nlo_corrections () type(string_t) :: nlo_correction_type type(pdg_array_t), dimension(:), allocatable :: pdg if (nlo_fixed_order .or. gks_active) then nlo_correction_type = & var_list%get_sval (var_str ('$nlo_correction_type')) select case (char(nlo_correction_type)) case ("QCD") qcd_corr = .true.; qed_corr = .false. case ("QED") qcd_corr = .false.; qed_corr = .true. case ("Full") qcd_corr =.true.; qed_corr = .true. case default call msg_fatal ("Invalid NLO correction type! " // & "Valid inputs are: QCD, QED, Full (default: QCD)") end select call check_for_excluded_gauge_boson_splitting_partners () call setup_radiation_generator () end if if (nlo_fixed_order) then call radiation_generator%find_splittings () if (debug2_active (D_CORE)) then print *, '' print *, 'Found (pdg) splittings: ' do i = 1, radiation_generator%if_table%get_length () call radiation_generator%if_table%get_pdg_out (i, pdg) call pdg_array_write_set (pdg) print *, '----------------' end do end if nlo_fixed_order = radiation_generator%contains_emissions () if (.not. nlo_fixed_order) call msg_warning & (arr = [var_str ("No NLO corrections found for process ") // & cmd%id // var_str("."), var_str ("Proceed with usual " // & "leading-order integration and simulation")]) end if end subroutine check_for_nlo_corrections @ %def check_for_nlo_corrections @ <>= subroutine check_for_excluded_gauge_boson_splitting_partners () type(string_t) :: str_excluded_partners type(string_t), dimension(:), allocatable :: excluded_partners type(pdg_list_t) :: pl_tmp, pl_anti integer :: i, n_anti str_excluded_partners = var_list%get_sval & (var_str ("$exclude_gauge_splittings")) if (str_excluded_partners == "") then return else call split_string (str_excluded_partners, & var_str (":"), excluded_partners) call pl_tmp%init (size (excluded_partners)) do i = 1, size (excluded_partners) call pl_tmp%set (i, & cmd%local%model%get_pdg (excluded_partners(i), .true.)) end do call pl_tmp%create_antiparticles (pl_anti, n_anti) call pl_excluded_gauge_splittings%init (pl_tmp%get_size () + n_anti) do i = 1, pl_tmp%get_size () call pl_excluded_gauge_splittings%set (i, pl_tmp%get(i)) end do do i = 1, n_anti j = i + pl_tmp%get_size () call pl_excluded_gauge_splittings%set (j, pl_anti%get(i)) end do end if end subroutine check_for_excluded_gauge_boson_splitting_partners @ %def check_for_excluded_gauge_boson_splitting_partners @ <>= subroutine determine_needed_components () type(string_t) :: fks_method comp_mult = 1 if (nlo_fixed_order) then fks_method = var_list%get_sval (var_str ('$fks_mapping_type')) call check_threshold_consistency () requires_soft_mismatch = fks_method == var_str ('resonances') comp_mult = needed_extra_components (requires_dglap_remnants, & use_real_finite, requires_soft_mismatch) allocate (i_list (comp_mult)) else if (gks_active) then call radiation_generator%generate_multiple & (gks_multiplicity, cmd%local%model) comp_mult = radiation_generator%get_n_gks_states () + 1 end if n_components_init = n_components * comp_mult end subroutine determine_needed_components @ %def determine_needed_components @ <>= subroutine setup_radiation_generator () call split_prt (prt_spec_in, n_in, pl_in) call split_prt (prt_spec_out, n_out, pl_out) call radiation_generator%init (pl_in, pl_out, & pl_excluded_gauge_splittings, qcd = qcd_corr, qed = qed_corr) call radiation_generator%set_n (n_in, n_out, 0) initial_state_colored = pdg_in%has_colored_particles () if ((n_in == 2 .and. initial_state_colored) .or. qed_corr) then requires_dglap_remnants = n_in == 2 .and. initial_state_colored call radiation_generator%set_initial_state_emissions () else requires_dglap_remnants = .false. end if call radiation_generator%set_constraints (.false., .false., .true., .true.) call radiation_generator%setup_if_table (cmd%local%model) end subroutine setup_radiation_generator @ %def setup_radiation_generator @ <>= subroutine scan_components () n_terms = prt_expr_out%get_n_terms () allocate (pdg_out_tab (n_terms)) allocate (i_term (n_terms), source = 0) n_components = 0 SCAN: do i = 1, n_terms if (allocated (pdg)) deallocate (pdg) call prt_expr_out%term_to_array (prt_spec_out, i) n_out = size (prt_spec_out) allocate (pdg (n_out)) do j = 1, n_out prt_out = prt_spec_out(j)%to_string () call split (prt_out, prt_out1, ":") pdg(j) = cmd%local%model%get_pdg (prt_out1) end do pdg_out = sort (pdg) do j = 1, n_components if (pdg_out == pdg_out_tab(j)) cycle SCAN end do n_components = n_components + 1 i_term(n_components) = i pdg_out_tab(n_components) = pdg_out end do SCAN end subroutine scan_components @ <>= subroutine split_prt (prt, n_out, pl) type(prt_spec_t), intent(in), dimension(:), allocatable :: prt integer, intent(in) :: n_out type(pdg_list_t), intent(out) :: pl type(pdg_array_t) :: pdg type(string_t) :: prt_string, prt_tmp integer, parameter :: max_particle_number = 25 integer, dimension(max_particle_number) :: i_particle integer :: i, j, n i_particle = 0 call pl%init (n_out) do i = 1, n_out n = 1 prt_string = prt(i)%to_string () do call split (prt_string, prt_tmp, ":") if (prt_tmp /= "") then i_particle(n) = cmd%local%model%get_pdg (prt_tmp) n = n + 1 else exit end if end do call pdg_array_init (pdg, n - 1) do j = 1, n - 1 call pdg%set (j, i_particle(j)) end do call pl%set (i, pdg) call pdg_array_delete (pdg) end do end subroutine split_prt @ %def split_prt @ <>= subroutine setup_components() integer :: k, i_comp, add_index i_comp = 0 add_index = 0 call msg_debug (D_CORE, "setup_components") do i = 1, n_components call prt_expr_out%term_to_array (prt_spec_out, i_term(i)) if (nlo_fixed_order) then associate (selected_nlo_parts => cmd%local%selected_nlo_parts) call msg_debug (D_CORE, "Setting up this NLO component:", & i_comp + 1) call prc_config%setup_component (i_comp + 1, & prt_spec_in, prt_spec_out, & cmd%local%model, var_list, BORN, & can_be_integrated = selected_nlo_parts (BORN)) call radiation_generator%generate_real_particle_strings & (prt_in_nlo, prt_out_nlo) call msg_debug (D_CORE, "Setting up this NLO component:", & i_comp + 2) call prc_config%setup_component (i_comp + 2, & new_prt_spec (prt_in_nlo), new_prt_spec (prt_out_nlo), & cmd%local%model, var_list, NLO_REAL, & can_be_integrated = selected_nlo_parts (NLO_REAL)) call msg_debug (D_CORE, "Setting up this NLO component:", & i_comp + 3) call prc_config%setup_component (i_comp + 3, & prt_spec_in, prt_spec_out, & cmd%local%model, var_list, NLO_VIRTUAL, & can_be_integrated = selected_nlo_parts (NLO_VIRTUAL)) call msg_debug (D_CORE, "Setting up this NLO component:", & i_comp + 4) call prc_config%setup_component (i_comp + 4, & prt_spec_in, prt_spec_out, & cmd%local%model, var_list, NLO_SUBTRACTION, & can_be_integrated = selected_nlo_parts (NLO_SUBTRACTION)) do k = 1, 4 i_list(k) = i_comp + k end do if (requires_dglap_remnants) then call msg_debug (D_CORE, "Setting up this NLO component:", & i_comp + 5) call prc_config%setup_component (i_comp + 5, & prt_spec_in, prt_spec_out, & cmd%local%model, var_list, NLO_DGLAP, & can_be_integrated = selected_nlo_parts (NLO_DGLAP)) i_list(5) = i_comp + 5 add_index = add_index + 1 end if if (use_real_finite) then call msg_debug (D_CORE, "Setting up this NLO component:", & i_comp + 5 + add_index) call prc_config%setup_component (i_comp + 5 + add_index, & new_prt_spec (prt_in_nlo), new_prt_spec (prt_out_nlo), & cmd%local%model, var_list, NLO_REAL, & can_be_integrated = selected_nlo_parts (NLO_REAL)) i_list(5 + add_index) = i_comp + 5 + add_index add_index = add_index + 1 end if if (requires_soft_mismatch) then call msg_debug (D_CORE, "Setting up this NLO component:", & i_comp + 5 + add_index) call prc_config%setup_component (i_comp + 5 + add_index, & prt_spec_in, prt_spec_out, & cmd%local%model, var_list, NLO_MISMATCH, & can_be_integrated = selected_nlo_parts (NLO_MISMATCH)) i_list(5 + add_index) = i_comp + 5 + add_index end if call prc_config%set_component_associations (i_list, & requires_dglap_remnants, use_real_finite, & requires_soft_mismatch) end associate else if (gks_active) then call prc_config%setup_component (i_comp + 1, prt_spec_in, & prt_spec_out, cmd%local%model, var_list, BORN, & can_be_integrated = .true.) call radiation_generator%reset_queue () do j = 1, comp_mult prt_out_nlo = radiation_generator%get_next_state () call prc_config%setup_component (i_comp + 1 + j, & new_prt_spec (prt_in), new_prt_spec (prt_out_nlo), & cmd%local%model, var_list, GKS, can_be_integrated = .false.) end do else call prc_config%setup_component (i, & prt_spec_in, prt_spec_out, & cmd%local%model, var_list, can_be_integrated = .true.) end if i_comp = i_comp + comp_mult end do end subroutine setup_components @ @ These three functions should be bundled with the logicals they depend on into an object (the pcm?). <>= subroutine check_nlo_options (local) type(rt_data_t), intent(in) :: local type(var_list_t), pointer :: var_list => null () logical :: nlo, combined, powheg logical :: case_lo_but_any_other logical :: case_nlo_powheg_but_not_combined logical :: vamp_equivalences_enabled logical :: fixed_order_nlo_events var_list => local%get_var_list_ptr () nlo = local%nlo_fixed_order combined = var_list%get_lval (var_str ('?combined_nlo_integration')) powheg = var_list%get_lval (var_str ('?powheg_matching')) case_lo_but_any_other = .not. nlo .and. any ([combined, powheg]) case_nlo_powheg_but_not_combined = & nlo .and. powheg .and. .not. combined if (case_lo_but_any_other) then call msg_fatal ("Option mismatch: Leading order process is selected & &but either powheg_matching or combined_nlo_integration & &is set to true.") else if (case_nlo_powheg_but_not_combined) then call msg_fatal ("POWHEG requires the 'combined_nlo_integration'-option & &to be set to true.") end if fixed_order_nlo_events = & var_list%get_lval (var_str ('?fixed_order_nlo_events')) if (fixed_order_nlo_events .and. .not. combined .and. & all (local%selected_nlo_parts)) & call msg_fatal ("Option mismatch: Fixed order NLO events of the full ", & [var_str ("process are requested, but ?combined_nlo_integration"), & var_str ("is false. You can either switch to the combined NLO"), & var_str ("integration mode or choose one individual NLO component"), & var_str ("to generate events with.")]) vamp_equivalences_enabled = var_list%get_lval & (var_str ('?use_vamp_equivalences')) if (nlo .and. vamp_equivalences_enabled) & call msg_warning ("You have not disabled VAMP equivalences. ", & [var_str (" Note that they are automatically switched off "), & var_str (" for NLO calculations.")]) end subroutine check_nlo_options @ %def check_nlo_options @ There are four components for a general NLO process, namely Born, real, virtual and subtraction. There will be additional components for DGLAP remnant, in case real contributions are split into singular and finite pieces, and for resonance-aware FKS subtraction for the needed soft mismatch component. <>= pure function needed_extra_components (requires_dglap_remnant, & use_real_finite, requires_soft_mismatch) result (n) integer :: n logical, intent(in) :: requires_dglap_remnant, & use_real_finite, requires_soft_mismatch n = 4 if (requires_dglap_remnant) n = n + 1 if (use_real_finite) n = n + 1 if (requires_soft_mismatch) n = n + 1 end function needed_extra_components @ %def needed_extra_components @ This is a method of the eval tree, but cannot be coded inside the [[expressions]] module since it uses the [[model]] and [[flv]] types which are not available there. <>= function make_flavor_string (aval, model) result (prt) type(string_t) :: prt type(pdg_array_t), intent(in) :: aval type(model_t), intent(in), target :: model integer, dimension(:), allocatable :: pdg type(flavor_t), dimension(:), allocatable :: flv integer :: i pdg = aval allocate (flv (size (pdg))) call flv%init (pdg, model) if (size (pdg) /= 0) then prt = flv(1)%get_name () do i = 2, size (flv) prt = prt // ":" // flv(i)%get_name () end do else prt = "?" end if end function make_flavor_string @ %def make_flavor_string @ Create a pdg array from a particle-specification array <>= function make_pdg_array (prt, model) result (pdg_array) type(prt_spec_t), intent(in), dimension(:) :: prt type(model_t), intent(in) :: model integer, dimension(:), allocatable :: aval type(pdg_array_t) :: pdg_array type(flavor_t) :: flv integer :: k allocate (aval (size (prt))) do k = 1, size (prt) call flv%init (prt(k)%to_string (), model) aval (k) = flv%get_pdg () end do pdg_array = aval end function make_pdg_array @ %def make_pdg_array @ Compile a (possible nested) expression, to obtain a particle-specifier expression which we can process further. <>= recursive subroutine compile_prt_expr (prt_expr, pn, var_list, model) type(prt_expr_t), intent(out) :: prt_expr type(parse_node_t), intent(in), target :: pn type(var_list_t), intent(in), target :: var_list type(model_t), intent(in), target :: model type(parse_node_t), pointer :: pn_entry, pn_term, pn_addition type(pdg_array_t) :: pdg type(string_t) :: prt_string integer :: n_entry, n_term, i select case (char (parse_node_get_rule_key (pn))) case ("prt_state_list") n_entry = parse_node_get_n_sub (pn) pn_entry => parse_node_get_sub_ptr (pn) if (n_entry == 1) then call compile_prt_expr (prt_expr, pn_entry, var_list, model) else call prt_expr%init_list (n_entry) select type (x => prt_expr%x) type is (prt_spec_list_t) do i = 1, n_entry call compile_prt_expr (x%expr(i), pn_entry, var_list, model) pn_entry => parse_node_get_next_ptr (pn_entry) end do end select end if case ("prt_state_sum") n_term = parse_node_get_n_sub (pn) pn_term => parse_node_get_sub_ptr (pn) pn_addition => pn_term if (n_term == 1) then call compile_prt_expr (prt_expr, pn_term, var_list, model) else call prt_expr%init_sum (n_term) select type (x => prt_expr%x) type is (prt_spec_sum_t) do i = 1, n_term call compile_prt_expr (x%expr(i), pn_term, var_list, model) pn_addition => parse_node_get_next_ptr (pn_addition) if (associated (pn_addition)) & pn_term => parse_node_get_sub_ptr (pn_addition, 2) end do end select end if case ("cexpr") pdg = eval_pdg_array (pn, var_list) prt_string = make_flavor_string (pdg, model) call prt_expr%init_spec (new_prt_spec (prt_string)) case default call parse_node_write_rec (pn) call msg_bug ("compile prt expr: impossible syntax rule") end select end subroutine compile_prt_expr @ %def compile_prt_expr @ \subsubsection{Initiating a NLO calculation} <>= type, extends (command_t) :: cmd_nlo_t private integer, dimension(:), allocatable :: nlo_component contains <> end type cmd_nlo_t @ %def cmd_nlo_t @ <>= procedure :: write => cmd_nlo_write <>= subroutine cmd_nlo_write (cmd, unit, indent) class(cmd_nlo_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent end subroutine cmd_nlo_write @ %def cmd_nlo_write @ As it is, the NLO calculation is switched on by putting {nlo} behind the process definition. This should be made nicer in the future. <>= procedure :: compile => cmd_nlo_compile <>= subroutine cmd_nlo_compile (cmd, global) class(cmd_nlo_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_arg, pn_comp integer :: i, n_comp pn_arg => parse_node_get_sub_ptr (cmd%pn, 3) if (associated (pn_arg)) then n_comp = parse_node_get_n_sub (pn_arg) allocate (cmd%nlo_component (n_comp)) pn_comp => parse_node_get_sub_ptr (pn_arg) i = 0 do while (associated (pn_comp)) i = i + 1 cmd%nlo_component(i) = component_status & (parse_node_get_rule_key (pn_comp)) pn_comp => parse_node_get_next_ptr (pn_comp) end do else allocate (cmd%nlo_component (0)) end if end subroutine cmd_nlo_compile @ %def cmd_nlo_compile @ <>= procedure :: execute => cmd_nlo_execute <>= subroutine cmd_nlo_execute (cmd, global) class(cmd_nlo_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(string_t) :: string integer :: n, i, j logical, dimension(0:5) :: selected_nlo_parts call msg_debug (D_CORE, "cmd_nlo_execute") selected_nlo_parts = .false. if (allocated (cmd%nlo_component)) then n = size (cmd%nlo_component) else n = 0 end if do i = 1, n select case (cmd%nlo_component (i)) case (BORN, NLO_VIRTUAL, NLO_MISMATCH, NLO_DGLAP, NLO_REAL) selected_nlo_parts(cmd%nlo_component (i)) = .true. case (NLO_FULL) selected_nlo_parts = .true. selected_nlo_parts (NLO_SUBTRACTION) = .false. case default string = var_str ("") do j = BORN, NLO_DGLAP string = string // component_status (j) // ", " end do string = string // component_status (NLO_FULL) call msg_fatal ("Invalid NLO mode. Valid modes are: " // & char (string)) end select end do global%nlo_fixed_order = any (selected_nlo_parts) global%selected_nlo_parts = selected_nlo_parts allocate (global%nlo_component (size (cmd%nlo_component))) global%nlo_component = cmd%nlo_component end subroutine cmd_nlo_execute @ %def cmd_nlo_execute @ \subsubsection{Process compilation} <>= type, extends (command_t) :: cmd_compile_t private type(string_t), dimension(:), allocatable :: libname logical :: make_executable = .false. type(string_t) :: exec_name contains <> end type cmd_compile_t @ %def cmd_compile_t @ Output: list all libraries to be compiled. <>= procedure :: write => cmd_compile_write <>= subroutine cmd_compile_write (cmd, unit, indent) class(cmd_compile_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, i u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)", advance="no") "compile (" if (allocated (cmd%libname)) then do i = 1, size (cmd%libname) if (i > 1) write (u, "(A,1x)", advance="no") "," write (u, "('""',A,'""')", advance="no") char (cmd%libname(i)) end do end if write (u, "(A)") ")" end subroutine cmd_compile_write @ %def cmd_compile_write @ Compile the libraries specified in the argument. If the argument is empty, compile all libraries which can be found in the process library stack. <>= procedure :: compile => cmd_compile_compile <>= subroutine cmd_compile_compile (cmd, global) class(cmd_compile_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_cmd, pn_clause, pn_arg, pn_lib type(parse_node_t), pointer :: pn_exec_name_spec, pn_exec_name integer :: n_lib, i pn_cmd => parse_node_get_sub_ptr (cmd%pn) pn_clause => parse_node_get_sub_ptr (pn_cmd) pn_exec_name_spec => parse_node_get_sub_ptr (pn_clause, 2) if (associated (pn_exec_name_spec)) then pn_exec_name => parse_node_get_sub_ptr (pn_exec_name_spec, 2) else pn_exec_name => null () end if pn_arg => parse_node_get_next_ptr (pn_clause) cmd%pn_opt => parse_node_get_next_ptr (pn_cmd) call cmd%compile_options (global) if (associated (pn_arg)) then n_lib = parse_node_get_n_sub (pn_arg) else n_lib = 0 end if if (n_lib > 0) then allocate (cmd%libname (n_lib)) pn_lib => parse_node_get_sub_ptr (pn_arg) do i = 1, n_lib cmd%libname(i) = parse_node_get_string (pn_lib) pn_lib => parse_node_get_next_ptr (pn_lib) end do end if if (associated (pn_exec_name)) then cmd%make_executable = .true. cmd%exec_name = parse_node_get_string (pn_exec_name) end if end subroutine cmd_compile_compile @ %def cmd_compile_compile @ Command execution. Generate code, write driver, compile and link. Do this for all libraries in the list. If no library names have been given and stored while compiling this command, we collect all libraries from the current stack and compile those. As a bonus, a compiled library may be able to spawn new process libraries. For instance, a processes may ask for a set of resonant subprocesses which go into their own library, but this can be determined only after the process is available as a compiled object. Therefore, the compilation loop is implemented as a recursive internal subroutine. We can compile static libraries (which actually just loads them). However, we can't incorporate in a generated executable. <>= procedure :: execute => cmd_compile_execute <>= subroutine cmd_compile_execute (cmd, global) class(cmd_compile_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(string_t), dimension(:), allocatable :: libname, libname_static integer :: i, n_lib <> <> if (allocated (cmd%libname)) then allocate (libname (size (cmd%libname))) libname = cmd%libname else call cmd%local%prclib_stack%get_names (libname) end if n_lib = size (libname) if (cmd%make_executable) then call get_prclib_static (libname_static) do i = 1, n_lib if (any (libname_static == libname(i))) then call msg_fatal ("Compile: can't include static library '" & // char (libname(i)) // "'") end if end do call compile_executable (cmd%exec_name, libname, cmd%local) else call compile_libraries (libname) call global%update_prclib & (global%prclib_stack%get_library_ptr (libname(n_lib))) end if <> contains recursive subroutine compile_libraries (libname) type(string_t), dimension(:), intent(in) :: libname integer :: i type(string_t), dimension(:), allocatable :: libname_extra type(process_library_t), pointer :: lib_saved do i = 1, size (libname) call compile_library (libname(i), cmd%local) lib_saved => global%prclib call spawn_extra_libraries & (libname(i), cmd%local, global, libname_extra) call compile_libraries (libname_extra) call global%update_prclib (lib_saved) end do end subroutine compile_libraries end subroutine cmd_compile_execute @ %def cmd_compile_execute <>= @ <>= @ <>= @ @ The parallelization leads to undefined behavior while writing simultaneously to one file. The master worker has to initialize single-handed the corresponding library files. The slave worker will wait with a blocking [[MPI_BCAST]] until they receive a logical flag. <>= logical :: compile_init integer :: rank, n_size <>= call msg_debug (D_MPI, "cmd_compile_execute") compile_init = .false. call mpi_get_comm_id (n_size, rank) call msg_debug (D_MPI, "n_size", rank) call msg_debug (D_MPI, "rank", rank) if (rank /= 0) then call msg_debug (D_MPI, "wait for master") call MPI_bcast (compile_init, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD) else compile_init = .true. end if if (compile_init) then <>= if (rank == 0) then call msg_debug (D_MPI, "load slaves") call MPI_bcast (compile_init, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD) end if end if call MPI_barrier (MPI_COMM_WORLD) @ %def cmd_compile_execute_mpi @ This is the interface to the external procedure which returns the names of all static libraries which are part of the executable. (The default is none.) The routine must allocate the array. <>= public :: get_prclib_static <>= interface subroutine get_prclib_static (libname) import type(string_t), dimension(:), intent(inout), allocatable :: libname end subroutine get_prclib_static end interface @ %def get_prclib_static @ Spawn extra libraries. We can ask the processes within a compiled library, which we have available at this point, whether they need additional processes which should go into their own libraries. The current implementation only concerns resonant subprocesses. Note that the libraries should be created (source code), but not be compiled here. This is done afterwards. <>= subroutine spawn_extra_libraries (libname, local, global, libname_extra) type(string_t), intent(in) :: libname type(rt_data_t), intent(inout), target :: local type(rt_data_t), intent(inout), target :: global type(string_t), dimension(:), allocatable, intent(out) :: libname_extra type(string_t), dimension(:), allocatable :: libname_res allocate (libname_extra (0)) call spawn_resonant_subprocess_libraries & (libname, local, global, libname_res) if (allocated (libname_res)) libname_extra = [libname_extra, libname_res] end subroutine spawn_extra_libraries @ %def spawn_extra_libraries @ \subsubsection{Execute a shell command} The argument is a string expression. <>= type, extends (command_t) :: cmd_exec_t private type(parse_node_t), pointer :: pn_command => null () contains <> end type cmd_exec_t @ %def cmd_exec_t @ Simply tell the status. <>= procedure :: write => cmd_exec_write <>= subroutine cmd_exec_write (cmd, unit, indent) class(cmd_exec_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) if (associated (cmd%pn_command)) then write (u, "(1x,A)") "exec: [command associated]" else write (u, "(1x,A)") "exec: [undefined]" end if end subroutine cmd_exec_write @ %def cmd_exec_write @ Compile the exec command. <>= procedure :: compile => cmd_exec_compile <>= subroutine cmd_exec_compile (cmd, global) class(cmd_exec_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_arg, pn_command pn_arg => parse_node_get_sub_ptr (cmd%pn, 2) pn_command => parse_node_get_sub_ptr (pn_arg) cmd%pn_command => pn_command end subroutine cmd_exec_compile @ %def cmd_exec_compile @ Execute the specified shell command. <>= procedure :: execute => cmd_exec_execute <>= subroutine cmd_exec_execute (cmd, global) class(cmd_exec_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(string_t) :: command logical :: is_known integer :: status command = eval_string (cmd%pn_command, global%var_list, is_known=is_known) if (is_known) then if (command /= "") then call os_system_call (command, status, verbose=.true.) if (status /= 0) then write (msg_buffer, "(A,I0)") "Return code = ", status call msg_message () call msg_error ("System command returned with nonzero status code") end if end if end if end subroutine cmd_exec_execute @ %def cmd_exec_execute @ \subsubsection{Variable declaration} A variable can have various types. Hold the definition as an eval tree. There are intrinsic variables, user variables, and model variables. The latter are further divided in independent variables and dependent variables. Regarding model variables: When dealing with them, we always look at two variable lists in parallel. The global (or local) variable list contains the user-visible values. It includes variables that correspond to variables in the current model's list. These, in turn, are pointers to the model's parameter list, so the model is always in sync, internally. To keep the global variable list in sync with the model, the global variables carry the [[is_copy]] property and contain a separate pointer to the model variable. (The pointer is reassigned whenever the model changes.) Modifying the global variable changes two values simultaneously: the visible value and the model variable, via this extra pointer. After each modification, we update dependent parameters in the model variable list and re-synchronize the global variable list (again, using these pointers) with the model variable this. In the last step, modifications in the derived parameters become visible. When we integrate a process, we capture the current variable list of the current model in a separate model instance, which is stored in the process object. Thus, the model parameters associated to this process at this time are preserved for the lifetime of the process object. When we generate or rescan events, we can again capture a local model variable list in a model instance. This allows us to reweight event by event with different parameter sets simultaneously. <>= type, extends (command_t) :: cmd_var_t private type(string_t) :: name integer :: type = V_NONE type(parse_node_t), pointer :: pn_value => null () logical :: is_intrinsic = .false. logical :: is_model_var = .false. contains <> end type cmd_var_t @ %def cmd_var_t @ Output. We know name, type, and properties, but not the value. <>= procedure :: write => cmd_var_write <>= subroutine cmd_var_write (cmd, unit, indent) class(cmd_var_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,A,A)", advance="no") "var: ", char (cmd%name), " (" select case (cmd%type) case (V_NONE) write (u, "(A)", advance="no") "[unknown]" case (V_LOG) write (u, "(A)", advance="no") "logical" case (V_INT) write (u, "(A)", advance="no") "int" case (V_REAL) write (u, "(A)", advance="no") "real" case (V_CMPLX) write (u, "(A)", advance="no") "complex" case (V_STR) write (u, "(A)", advance="no") "string" case (V_PDG) write (u, "(A)", advance="no") "alias" end select if (cmd%is_intrinsic) then write (u, "(A)", advance="no") ", intrinsic" end if if (cmd%is_model_var) then write (u, "(A)", advance="no") ", model" end if write (u, "(A)") ")" end subroutine cmd_var_write @ %def cmd_var_write @ Compile the lhs and determine the variable name and type. Check whether this variable can be created or modified as requested, and append the value to the variable list, if appropriate. The value is initially undefined. The rhs is assigned to a pointer, to be compiled and evaluated when the command is executed. <>= procedure :: compile => cmd_var_compile <>= subroutine cmd_var_compile (cmd, global) class(cmd_var_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_var, pn_name type(parse_node_t), pointer :: pn_result, pn_proc type(string_t) :: var_name type(var_list_t), pointer :: model_vars integer :: type logical :: new pn_result => null () new = .false. select case (char (parse_node_get_rule_key (cmd%pn))) case ("cmd_log_decl"); type = V_LOG pn_var => parse_node_get_sub_ptr (cmd%pn, 2) if (.not. associated (pn_var)) then ! handle masked syntax error cmd%type = V_NONE; return end if pn_name => parse_node_get_sub_ptr (pn_var, 2) new = .true. case ("cmd_log"); type = V_LOG pn_name => parse_node_get_sub_ptr (cmd%pn, 2) case ("cmd_int"); type = V_INT pn_name => parse_node_get_sub_ptr (cmd%pn, 2) new = .true. case ("cmd_real"); type = V_REAL pn_name => parse_node_get_sub_ptr (cmd%pn, 2) new = .true. case ("cmd_complex"); type = V_CMPLX pn_name => parse_node_get_sub_ptr (cmd%pn, 2) new = .true. case ("cmd_num"); type = V_NONE pn_name => parse_node_get_sub_ptr (cmd%pn) case ("cmd_string_decl"); type = V_STR pn_var => parse_node_get_sub_ptr (cmd%pn, 2) if (.not. associated (pn_var)) then ! handle masked syntax error cmd%type = V_NONE; return end if pn_name => parse_node_get_sub_ptr (pn_var, 2) new = .true. case ("cmd_string"); type = V_STR pn_name => parse_node_get_sub_ptr (cmd%pn, 2) case ("cmd_alias"); type = V_PDG pn_name => parse_node_get_sub_ptr (cmd%pn, 2) new = .true. case ("cmd_result"); type = V_REAL pn_name => parse_node_get_sub_ptr (cmd%pn) pn_result => parse_node_get_sub_ptr (pn_name) pn_proc => parse_node_get_next_ptr (pn_result) case default call parse_node_mismatch & ("logical|int|real|complex|?|$|alias|var_name", cmd%pn) ! $ end select if (.not. associated (pn_name)) then ! handle masked syntax error cmd%type = V_NONE; return end if if (.not. associated (pn_result)) then var_name = parse_node_get_string (pn_name) else var_name = parse_node_get_key (pn_result) & // "(" // parse_node_get_string (pn_proc) // ")" end if select case (type) case (V_LOG); var_name = "?" // var_name case (V_STR); var_name = "$" // var_name ! $ end select if (associated (global%model)) then model_vars => global%model%get_var_list_ptr () else model_vars => null () end if call var_list_check_observable (global%var_list, var_name, type) call var_list_check_result_var (global%var_list, var_name, type) call global%var_list%check_user_var (var_name, type, new) cmd%name = var_name cmd%pn_value => parse_node_get_next_ptr (pn_name, 2) if (global%var_list%contains (cmd%name, follow_link = .false.)) then ! local variable cmd%is_intrinsic = & global%var_list%is_intrinsic (cmd%name, follow_link = .false.) cmd%type = & global%var_list%get_type (cmd%name, follow_link = .false.) else if (new) cmd%type = type if (global%var_list%contains (cmd%name, follow_link = .true.)) then ! global variable cmd%is_intrinsic = & global%var_list%is_intrinsic (cmd%name, follow_link = .true.) if (cmd%type == V_NONE) then cmd%type = & global%var_list%get_type (cmd%name, follow_link = .true.) end if else if (associated (model_vars)) then ! check model variable cmd%is_model_var = & model_vars%contains (cmd%name) if (cmd%type == V_NONE) then cmd%type = & model_vars%get_type (cmd%name) end if end if if (cmd%type == V_NONE) then call msg_fatal ("Variable '" // char (cmd%name) // "' " & // "set without declaration") cmd%type = V_NONE; return end if if (cmd%is_model_var) then if (new) then call msg_fatal ("Model variable '" // char (cmd%name) // "' " & // "redeclared") else if (model_vars%is_locked (cmd%name)) then call msg_fatal ("Model variable '" // char (cmd%name) // "' " & // "is locked") end if else select case (cmd%type) case (V_LOG) call global%var_list%append_log (cmd%name, & intrinsic=cmd%is_intrinsic, user=.true.) case (V_INT) call global%var_list%append_int (cmd%name, & intrinsic=cmd%is_intrinsic, user=.true.) case (V_REAL) call global%var_list%append_real (cmd%name, & intrinsic=cmd%is_intrinsic, user=.true.) case (V_CMPLX) call global%var_list%append_cmplx (cmd%name, & intrinsic=cmd%is_intrinsic, user=.true.) case (V_PDG) call global%var_list%append_pdg_array (cmd%name, & intrinsic=cmd%is_intrinsic, user=.true.) case (V_STR) call global%var_list%append_string (cmd%name, & intrinsic=cmd%is_intrinsic, user=.true.) end select end if end if end subroutine cmd_var_compile @ %def cmd_var_compile @ Execute. Evaluate the definition and assign the variable value. If the variable is a model variable, take a snapshot of the model if necessary and set the variable in the local model. <>= procedure :: execute => cmd_var_execute <>= subroutine cmd_var_execute (cmd, global) class(cmd_var_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list real(default) :: rval logical :: is_known, pacified var_list => global%get_var_list_ptr () if (cmd%is_model_var) then pacified = var_list%get_lval (var_str ("?pacify")) rval = eval_real (cmd%pn_value, var_list, is_known=is_known) call global%model_set_real & (cmd%name, rval, verbose=.true., pacified=pacified) else if (cmd%type /= V_NONE) then call cmd%set_value (var_list, verbose=.true.) end if end subroutine cmd_var_execute @ %def cmd_var_execute @ Copy the value to the variable list, where the variable should already exist. <>= procedure :: set_value => cmd_var_set_value <>= subroutine cmd_var_set_value (var, var_list, verbose, model_name) class(cmd_var_t), intent(inout) :: var type(var_list_t), intent(inout), target :: var_list logical, intent(in), optional :: verbose type(string_t), intent(in), optional :: model_name logical :: lval, pacified integer :: ival real(default) :: rval complex(default) :: cval type(pdg_array_t) :: aval type(string_t) :: sval logical :: is_known pacified = var_list%get_lval (var_str ("?pacify")) select case (var%type) case (V_LOG) lval = eval_log (var%pn_value, var_list, is_known=is_known) call var_list%set_log (var%name, & lval, is_known, verbose=verbose, model_name=model_name) case (V_INT) ival = eval_int (var%pn_value, var_list, is_known=is_known) call var_list%set_int (var%name, & ival, is_known, verbose=verbose, model_name=model_name) case (V_REAL) rval = eval_real (var%pn_value, var_list, is_known=is_known) call var_list%set_real (var%name, & rval, is_known, verbose=verbose, & model_name=model_name, pacified = pacified) case (V_CMPLX) cval = eval_cmplx (var%pn_value, var_list, is_known=is_known) call var_list%set_cmplx (var%name, & cval, is_known, verbose=verbose, & model_name=model_name, pacified = pacified) case (V_PDG) aval = eval_pdg_array (var%pn_value, var_list, is_known=is_known) call var_list%set_pdg_array (var%name, & aval, is_known, verbose=verbose, model_name=model_name) case (V_STR) sval = eval_string (var%pn_value, var_list, is_known=is_known) call var_list%set_string (var%name, & sval, is_known, verbose=verbose, model_name=model_name) end select end subroutine cmd_var_set_value @ %def cmd_var_set_value @ \subsubsection{SLHA} Read a SLHA (SUSY Les Houches Accord) file to fill the appropriate model parameters. We do not access the current variable record, but directly work on the appropriate SUSY model, which is loaded if necessary. We may be in read or write mode. In the latter case, we may write just input parameters, or the complete spectrum, or the spectrum with all decays. <>= type, extends (command_t) :: cmd_slha_t private type(string_t) :: file logical :: write_mode = .false. contains <> end type cmd_slha_t @ %def cmd_slha_t @ Output. <>= procedure :: write => cmd_slha_write <>= subroutine cmd_slha_write (cmd, unit, indent) class(cmd_slha_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,A)") "slha: file name = ", char (cmd%file) write (u, "(1x,A,L1)") "slha: write mode = ", cmd%write_mode end subroutine cmd_slha_write @ %def cmd_slha_write @ Compile. Read the filename and store it. <>= procedure :: compile => cmd_slha_compile <>= subroutine cmd_slha_compile (cmd, global) class(cmd_slha_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_key, pn_arg, pn_file pn_key => parse_node_get_sub_ptr (cmd%pn) pn_arg => parse_node_get_next_ptr (pn_key) pn_file => parse_node_get_sub_ptr (pn_arg) call cmd%compile_options (global) cmd%pn_opt => parse_node_get_next_ptr (pn_arg) select case (char (parse_node_get_key (pn_key))) case ("read_slha") cmd%write_mode = .false. case ("write_slha") cmd%write_mode = .true. case default call parse_node_mismatch ("read_slha|write_slha", cmd%pn) end select cmd%file = parse_node_get_string (pn_file) end subroutine cmd_slha_compile @ %def cmd_slha_compile @ Execute. Read or write the specified SLHA file. Behind the scenes, this will first read the WHIZARD model file, then read the SLHA file and assign the SLHA parameters as far as determined by [[dispatch_slha]]. Finally, the global variables are synchronized with the model. This is similar to executing [[cmd_model]]. <>= procedure :: execute => cmd_slha_execute <>= subroutine cmd_slha_execute (cmd, global) class(cmd_slha_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global logical :: input, spectrum, decays if (cmd%write_mode) then input = .true. spectrum = .false. decays = .false. if (.not. associated (cmd%local%model)) then call msg_fatal ("SLHA: local model not associated") return end if call slha_write_file & (cmd%file, cmd%local%model, & input = input, spectrum = spectrum, decays = decays) else if (.not. associated (global%model)) then call msg_fatal ("SLHA: global model not associated") return end if call dispatch_slha (cmd%local%var_list, & input = input, spectrum = spectrum, decays = decays) call global%ensure_model_copy () call slha_read_file & (cmd%file, cmd%local%os_data, global%model, & input = input, spectrum = spectrum, decays = decays) end if end subroutine cmd_slha_execute @ %def cmd_slha_execute @ \subsubsection{Show values} This command shows the current values of variables or other objects, in a suitably condensed form. <>= type, extends (command_t) :: cmd_show_t private type(string_t), dimension(:), allocatable :: name contains <> end type cmd_show_t @ %def cmd_show_t @ Output: list the object names, not values. <>= procedure :: write => cmd_show_write <>= subroutine cmd_show_write (cmd, unit, indent) class(cmd_show_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, i u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)", advance="no") "show: " if (allocated (cmd%name)) then do i = 1, size (cmd%name) write (u, "(1x,A)", advance="no") char (cmd%name(i)) end do write (u, *) else write (u, "(5x,A)") "[undefined]" end if end subroutine cmd_show_write @ %def cmd_show_write @ Compile. Allocate an array which is filled with the names of the variables to show. <>= procedure :: compile => cmd_show_compile <>= subroutine cmd_show_compile (cmd, global) class(cmd_show_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_arg, pn_var, pn_prefix, pn_name type(string_t) :: key integer :: i, n_args pn_arg => parse_node_get_sub_ptr (cmd%pn, 2) if (associated (pn_arg)) then select case (char (parse_node_get_rule_key (pn_arg))) case ("show_arg") cmd%pn_opt => parse_node_get_next_ptr (pn_arg) case default cmd%pn_opt => pn_arg pn_arg => null () end select end if call cmd%compile_options (global) if (associated (pn_arg)) then n_args = parse_node_get_n_sub (pn_arg) allocate (cmd%name (n_args)) pn_var => parse_node_get_sub_ptr (pn_arg) i = 0 do while (associated (pn_var)) i = i + 1 select case (char (parse_node_get_rule_key (pn_var))) case ("model", "library", "beams", "iterations", & "cuts", "weight", "int", "real", "complex", & "scale", "factorization_scale", "renormalization_scale", & "selection", "reweight", "analysis", "pdg", & "stable", "unstable", "polarized", "unpolarized", & "results", "expect", "intrinsic", "string", "logical") cmd%name(i) = parse_node_get_key (pn_var) case ("result_var") pn_prefix => parse_node_get_sub_ptr (pn_var) pn_name => parse_node_get_next_ptr (pn_prefix) if (associated (pn_name)) then cmd%name(i) = parse_node_get_key (pn_prefix) & // "(" // parse_node_get_string (pn_name) // ")" else cmd%name(i) = parse_node_get_key (pn_prefix) end if case ("log_var", "string_var", "alias_var") pn_prefix => parse_node_get_sub_ptr (pn_var) pn_name => parse_node_get_next_ptr (pn_prefix) key = parse_node_get_key (pn_prefix) if (associated (pn_name)) then select case (char (parse_node_get_rule_key (pn_name))) case ("var_name") select case (char (key)) case ("?", "$") ! $ sign cmd%name(i) = key // parse_node_get_string (pn_name) case ("alias") cmd%name(i) = parse_node_get_string (pn_name) end select case default call parse_node_mismatch & ("var_name", pn_name) end select else cmd%name(i) = key end if case default cmd%name(i) = parse_node_get_string (pn_var) end select pn_var => parse_node_get_next_ptr (pn_var) end do else allocate (cmd%name (0)) end if end subroutine cmd_show_compile @ %def cmd_show_compile @ Execute. Scan the list of objects to show. <>= integer, parameter, public :: SHOW_BUFFER_SIZE = 4096 <>= procedure :: execute => cmd_show_execute <>= subroutine cmd_show_execute (cmd, global) class(cmd_show_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list, model_vars type(model_t), pointer :: model type(string_t) :: name integer :: n, pdg type(flavor_t) :: flv type(process_library_t), pointer :: prc_lib type(process_t), pointer :: process logical :: pacified character(SHOW_BUFFER_SIZE) :: buffer type(string_t) :: out_file integer :: i, j, u, u_log, u_out, u_ext u = free_unit () var_list => cmd%local%var_list if (associated (cmd%local%model)) then model_vars => cmd%local%model%get_var_list_ptr () else model_vars => null () end if pacified = var_list%get_lval (var_str ("?pacify")) out_file = var_list%get_sval (var_str ("$out_file")) if (file_list_is_open (global%out_files, out_file, action="write")) then call msg_message ("show: copying output to file '" & // char (out_file) // "'") u_ext = file_list_get_unit (global%out_files, out_file) else u_ext = -1 end if open (u, status = "scratch", action = "readwrite") if (associated (cmd%local%model)) then name = cmd%local%model%get_name () end if if (size (cmd%name) == 0) then if (associated (model_vars)) then call model_vars%write (model_name = name, & unit = u, pacified = pacified, follow_link = .false.) end if call var_list%write (unit = u, pacified = pacified) else do i = 1, size (cmd%name) select case (char (cmd%name(i))) case ("model") if (associated (cmd%local%model)) then call cmd%local%model%show (u) else write (u, "(A)") "Model: [undefined]" end if case ("library") if (associated (cmd%local%prclib)) then call cmd%local%prclib%show (u) else write (u, "(A)") "Process library: [undefined]" end if case ("beams") call cmd%local%show_beams (u) case ("iterations") call cmd%local%it_list%write (u) case ("results") call cmd%local%process_stack%show (u, fifo=.true.) case ("stable") call cmd%local%model%show_stable (u) case ("polarized") call cmd%local%model%show_polarized (u) case ("unpolarized") call cmd%local%model%show_unpolarized (u) case ("unstable") model => cmd%local%model call model%show_unstable (u) n = model%get_n_field () do j = 1, n pdg = model%get_pdg (j) call flv%init (pdg, model) if (.not. flv%is_stable ()) & call show_unstable (cmd%local, pdg, u) if (flv%has_antiparticle ()) then associate (anti => flv%anti ()) if (.not. anti%is_stable ()) & call show_unstable (cmd%local, -pdg, u) end associate end if end do case ("cuts", "weight", "scale", & "factorization_scale", "renormalization_scale", & "selection", "reweight", "analysis") call cmd%local%pn%show (cmd%name(i), u) case ("expect") call expect_summary (force = .true.) case ("intrinsic") call var_list%write (intrinsic=.true., unit=u, & pacified = pacified) case ("logical") if (associated (model_vars)) then call model_vars%write (only_type=V_LOG, & model_name = name, unit=u, pacified = pacified, & follow_link=.false.) end if call var_list%write (& only_type=V_LOG, unit=u, pacified = pacified) case ("int") if (associated (model_vars)) then call model_vars%write (only_type=V_INT, & model_name = name, unit=u, pacified = pacified, & follow_link=.false.) end if call var_list%write (only_type=V_INT, & unit=u, pacified = pacified) case ("real") if (associated (model_vars)) then call model_vars%write (only_type=V_REAL, & model_name = name, unit=u, pacified = pacified, & follow_link=.false.) end if call var_list%write (only_type=V_REAL, & unit=u, pacified = pacified) case ("complex") if (associated (model_vars)) then call model_vars%write (only_type=V_CMPLX, & model_name = name, unit=u, pacified = pacified, & follow_link=.false.) end if call var_list%write (only_type=V_CMPLX, & unit=u, pacified = pacified) case ("pdg") if (associated (model_vars)) then call model_vars%write (only_type=V_PDG, & model_name = name, unit=u, pacified = pacified, & follow_link=.false.) end if call var_list%write (only_type=V_PDG, & unit=u, pacified = pacified) case ("string") if (associated (model_vars)) then call model_vars%write (only_type=V_STR, & model_name = name, unit=u, pacified = pacified, & follow_link=.false.) end if call var_list%write (only_type=V_STR, & unit=u, pacified = pacified) case default if (analysis_exists (cmd%name(i))) then call analysis_write (cmd%name(i), u) else if (cmd%local%process_stack%exists (cmd%name(i))) then process => cmd%local%process_stack%get_process_ptr (cmd%name(i)) call process%show (u) else if (associated (cmd%local%prclib_stack%get_library_ptr & (cmd%name(i)))) then prc_lib => cmd%local%prclib_stack%get_library_ptr (cmd%name(i)) call prc_lib%show (u) else if (associated (model_vars)) then if (model_vars%contains (cmd%name(i), follow_link=.false.)) then call model_vars%write_var (cmd%name(i), & unit = u, model_name = name, pacified = pacified) else if (var_list%contains (cmd%name(i))) then call var_list%write_var (cmd%name(i), & unit = u, pacified = pacified) else call msg_error ("show: object '" // char (cmd%name(i)) & // "' not found") end if else if (var_list%contains (cmd%name(i))) then call var_list%write_var (cmd%name(i), & unit = u, pacified = pacified) else call msg_error ("show: object '" // char (cmd%name(i)) & // "' not found") end if end select end do end if rewind (u) u_log = logfile_unit () u_out = given_output_unit () do read (u, "(A)", end = 1) buffer if (u_log > 0) write (u_log, "(A)") trim (buffer) if (u_out > 0) write (u_out, "(A)") trim (buffer) if (u_ext > 0) write (u_ext, "(A)") trim (buffer) end do 1 close (u) if (u_log > 0) flush (u_log) if (u_out > 0) flush (u_out) if (u_ext > 0) flush (u_ext) end subroutine cmd_show_execute @ %def cmd_show_execute @ \subsubsection{Clear values} This command clears the current values of variables or other objects, where this makes sense. It parallels the [[show]] command. The objects are cleared, but not deleted. <>= type, extends (command_t) :: cmd_clear_t private type(string_t), dimension(:), allocatable :: name contains <> end type cmd_clear_t @ %def cmd_clear_t @ Output: list the names of the objects to be cleared. <>= procedure :: write => cmd_clear_write <>= subroutine cmd_clear_write (cmd, unit, indent) class(cmd_clear_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, i u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)", advance="no") "clear: " if (allocated (cmd%name)) then do i = 1, size (cmd%name) write (u, "(1x,A)", advance="no") char (cmd%name(i)) end do write (u, *) else write (u, "(5x,A)") "[undefined]" end if end subroutine cmd_clear_write @ %def cmd_clear_write @ Compile. Allocate an array which is filled with the names of the objects to be cleared. Note: there is currently no need to account for options, but we prepare for that possibility. <>= procedure :: compile => cmd_clear_compile <>= subroutine cmd_clear_compile (cmd, global) class(cmd_clear_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_arg, pn_var, pn_prefix, pn_name type(string_t) :: key integer :: i, n_args pn_arg => parse_node_get_sub_ptr (cmd%pn, 2) if (associated (pn_arg)) then select case (char (parse_node_get_rule_key (pn_arg))) case ("clear_arg") cmd%pn_opt => parse_node_get_next_ptr (pn_arg) case default cmd%pn_opt => pn_arg pn_arg => null () end select end if call cmd%compile_options (global) if (associated (pn_arg)) then n_args = parse_node_get_n_sub (pn_arg) allocate (cmd%name (n_args)) pn_var => parse_node_get_sub_ptr (pn_arg) i = 0 do while (associated (pn_var)) i = i + 1 select case (char (parse_node_get_rule_key (pn_var))) case ("beams", "iterations", & "cuts", "weight", & "scale", "factorization_scale", "renormalization_scale", & "selection", "reweight", "analysis", & "unstable", "polarized", & "expect") cmd%name(i) = parse_node_get_key (pn_var) case ("log_var", "string_var") pn_prefix => parse_node_get_sub_ptr (pn_var) pn_name => parse_node_get_next_ptr (pn_prefix) key = parse_node_get_key (pn_prefix) if (associated (pn_name)) then select case (char (parse_node_get_rule_key (pn_name))) case ("var_name") select case (char (key)) case ("?", "$") ! $ sign cmd%name(i) = key // parse_node_get_string (pn_name) end select case default call parse_node_mismatch & ("var_name", pn_name) end select else cmd%name(i) = key end if case default cmd%name(i) = parse_node_get_string (pn_var) end select pn_var => parse_node_get_next_ptr (pn_var) end do else allocate (cmd%name (0)) end if end subroutine cmd_clear_compile @ %def cmd_clear_compile @ Execute. Scan the list of objects to clear. Objects that can be shown but not cleared: model, library, results <>= procedure :: execute => cmd_clear_execute <>= subroutine cmd_clear_execute (cmd, global) class(cmd_clear_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global integer :: i logical :: success type(var_list_t), pointer :: model_vars if (size (cmd%name) == 0) then call msg_warning ("clear: no object specified") else do i = 1, size (cmd%name) success = .true. select case (char (cmd%name(i))) case ("beams") call cmd%local%clear_beams () case ("iterations") call cmd%local%it_list%clear () case ("polarized") call cmd%local%model%clear_polarized () case ("unstable") call cmd%local%model%clear_unstable () case ("cuts", "weight", "scale", & "factorization_scale", "renormalization_scale", & "selection", "reweight", "analysis") call cmd%local%pn%clear (cmd%name(i)) case ("expect") call expect_clear () case default if (analysis_exists (cmd%name(i))) then call analysis_clear (cmd%name(i)) else if (cmd%local%var_list%contains (cmd%name(i))) then if (.not. cmd%local%var_list%is_locked (cmd%name(i))) then call cmd%local%var_list%unset (cmd%name(i)) else call msg_error ("clear: variable '" // char (cmd%name(i)) & // "' is locked and can't be cleared") success = .false. end if else if (associated (cmd%local%model)) then model_vars => cmd%local%model%get_var_list_ptr () if (model_vars%contains (cmd%name(i), follow_link=.false.)) then call msg_error ("clear: variable '" // char (cmd%name(i)) & // "' is a model variable and can't be cleared") else call msg_error ("clear: object '" // char (cmd%name(i)) & // "' not found") end if success = .false. else call msg_error ("clear: object '" // char (cmd%name(i)) & // "' not found") success = .false. end if end select if (success) call msg_message ("cleared: " // char (cmd%name(i))) end do end if end subroutine cmd_clear_execute @ %def cmd_clear_execute @ \subsubsection{Compare values of variables to expectation} The implementation is similar to the [[show]] command. There are just two arguments: two values that should be compared. For providing local values for the numerical tolerance, the command has a local argument list. If the expectation fails, an error condition is recorded. <>= type, extends (command_t) :: cmd_expect_t private type(parse_node_t), pointer :: pn_lexpr => null () contains <> end type cmd_expect_t @ %def cmd_expect_t @ Simply tell the status. <>= procedure :: write => cmd_expect_write <>= subroutine cmd_expect_write (cmd, unit, indent) class(cmd_expect_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) if (associated (cmd%pn_lexpr)) then write (u, "(1x,A)") "expect: [expression associated]" else write (u, "(1x,A)") "expect: [undefined]" end if end subroutine cmd_expect_write @ %def cmd_expect_write @ Compile. This merely assigns the parse node, the actual compilation is done at execution. This is necessary because the origin of variables (local/global) may change during execution. <>= procedure :: compile => cmd_expect_compile <>= subroutine cmd_expect_compile (cmd, global) class(cmd_expect_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_arg pn_arg => parse_node_get_sub_ptr (cmd%pn, 2) cmd%pn_opt => parse_node_get_next_ptr (pn_arg) cmd%pn_lexpr => parse_node_get_sub_ptr (pn_arg) call cmd%compile_options (global) end subroutine cmd_expect_compile @ %def cmd_expect_compile @ Execute. Evaluate both arguments, print them and their difference (if numerical), and whether they agree. Record the result. <>= procedure :: execute => cmd_expect_execute <>= subroutine cmd_expect_execute (cmd, global) class(cmd_expect_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list logical :: success, is_known var_list => cmd%local%get_var_list_ptr () success = eval_log (cmd%pn_lexpr, var_list, is_known=is_known) if (is_known) then if (success) then call msg_message ("expect: success") else call msg_error ("expect: failure") end if else call msg_error ("expect: undefined result") success = .false. end if call expect_record (success) end subroutine cmd_expect_execute @ %def cmd_expect_execute @ \subsubsection{Beams} The beam command includes both beam and structure-function definition. <>= type, extends (command_t) :: cmd_beams_t private integer :: n_in = 0 type(parse_node_p), dimension(:), allocatable :: pn_pdg integer :: n_sf_record = 0 integer, dimension(:), allocatable :: n_entry type(parse_node_p), dimension(:,:), allocatable :: pn_sf_entry contains <> end type cmd_beams_t @ %def cmd_beams_t @ Output. The particle expressions are not resolved. <>= procedure :: write => cmd_beams_write <>= subroutine cmd_beams_write (cmd, unit, indent) class(cmd_beams_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) select case (cmd%n_in) case (1) write (u, "(1x,A)") "beams: 1 [decay]" case (2) write (u, "(1x,A)") "beams: 2 [scattering]" case default write (u, "(1x,A)") "beams: [undefined]" end select if (allocated (cmd%n_entry)) then if (cmd%n_sf_record > 0) then write (u, "(1x,A,99(1x,I0))") "structure function entries:", & cmd%n_entry end if end if end subroutine cmd_beams_write @ %def cmd_beams_write @ Compile. Find and assign the parse nodes. Note: local environments are not yet supported. <>= procedure :: compile => cmd_beams_compile <>= subroutine cmd_beams_compile (cmd, global) class(cmd_beams_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_beam_def, pn_beam_spec type(parse_node_t), pointer :: pn_beam_list type(parse_node_t), pointer :: pn_codes type(parse_node_t), pointer :: pn_strfun_seq, pn_strfun_pair type(parse_node_t), pointer :: pn_strfun_def integer :: i pn_beam_def => parse_node_get_sub_ptr (cmd%pn, 3) pn_beam_spec => parse_node_get_sub_ptr (pn_beam_def) pn_strfun_seq => parse_node_get_next_ptr (pn_beam_spec) pn_beam_list => parse_node_get_sub_ptr (pn_beam_spec) call cmd%compile_options (global) cmd%n_in = parse_node_get_n_sub (pn_beam_list) allocate (cmd%pn_pdg (cmd%n_in)) pn_codes => parse_node_get_sub_ptr (pn_beam_list) do i = 1, cmd%n_in cmd%pn_pdg(i)%ptr => pn_codes pn_codes => parse_node_get_next_ptr (pn_codes) end do if (associated (pn_strfun_seq)) then cmd%n_sf_record = parse_node_get_n_sub (pn_beam_def) - 1 allocate (cmd%n_entry (cmd%n_sf_record), source = 1) allocate (cmd%pn_sf_entry (2, cmd%n_sf_record)) do i = 1, cmd%n_sf_record pn_strfun_pair => parse_node_get_sub_ptr (pn_strfun_seq, 2) pn_strfun_def => parse_node_get_sub_ptr (pn_strfun_pair) cmd%pn_sf_entry(1,i)%ptr => pn_strfun_def pn_strfun_def => parse_node_get_next_ptr (pn_strfun_def) cmd%pn_sf_entry(2,i)%ptr => pn_strfun_def if (associated (pn_strfun_def)) cmd%n_entry(i) = 2 pn_strfun_seq => parse_node_get_next_ptr (pn_strfun_seq) end do else allocate (cmd%n_entry (0)) allocate (cmd%pn_sf_entry (0, 0)) end if end subroutine cmd_beams_compile @ %def cmd_beams_compile @ Command execution: Determine beam particles and structure-function names, if any. The results are stored in the [[beam_structure]] component of the [[global]] data block. <>= procedure :: execute => cmd_beams_execute <>= subroutine cmd_beams_execute (cmd, global) class(cmd_beams_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(pdg_array_t) :: pdg_array integer, dimension(:), allocatable :: pdg type(flavor_t), dimension(:), allocatable :: flv type(parse_node_t), pointer :: pn_key type(string_t) :: sf_name integer :: i, j call lhapdf_global_reset () var_list => cmd%local%get_var_list_ptr () allocate (flv (cmd%n_in)) do i = 1, cmd%n_in pdg_array = eval_pdg_array (cmd%pn_pdg(i)%ptr, var_list) pdg = pdg_array select case (size (pdg)) case (1) call flv(i)%init ( pdg(1), cmd%local%model) case default call msg_fatal ("Beams: beam particles must be unique") end select end do select case (cmd%n_in) case (1) if (cmd%n_sf_record > 0) then call msg_fatal ("Beam setup: no structure functions allowed & &for decay") end if call global%beam_structure%init_sf (flv%get_name ()) case (2) call global%beam_structure%init_sf (flv%get_name (), cmd%n_entry) do i = 1, cmd%n_sf_record do j = 1, cmd%n_entry(i) pn_key => parse_node_get_sub_ptr (cmd%pn_sf_entry(j,i)%ptr) sf_name = parse_node_get_key (pn_key) call global%beam_structure%set_sf (i, j, sf_name) end do end do end select end subroutine cmd_beams_execute @ %def cmd_beams_execute @ \subsubsection{Density matrices for beam polarization} For holding beam polarization, we define a notation and a data structure for sparse matrices. The entries (and the index expressions) are numerical expressions, so we use evaluation trees. Each entry in the sparse matrix is an n-tuple of expressions. The first tuple elements represent index values, the last one is an arbitrary (complex) number. Absent expressions are replaced by default-value rules. Note: Here, and in some other commands, we would like to store an evaluation tree, not just a parse node pointer. However, the current expression handler wants all variables defined, so the evaluation tree can only be built by [[evaluate]], i.e., compiled just-in-time and evaluated immediately. <>= type :: sentry_expr_t type(parse_node_p), dimension(:), allocatable :: expr contains <> end type sentry_expr_t @ %def sentry_expr_t @ Compile parse nodes into evaluation trees. <>= procedure :: compile => sentry_expr_compile <>= subroutine sentry_expr_compile (sentry, pn) class(sentry_expr_t), intent(out) :: sentry type(parse_node_t), intent(in), target :: pn type(parse_node_t), pointer :: pn_expr, pn_extra integer :: n_expr, i n_expr = parse_node_get_n_sub (pn) allocate (sentry%expr (n_expr)) if (n_expr > 0) then i = 0 pn_expr => parse_node_get_sub_ptr (pn) pn_extra => parse_node_get_next_ptr (pn_expr) do i = 1, n_expr sentry%expr(i)%ptr => pn_expr if (associated (pn_extra)) then pn_expr => parse_node_get_sub_ptr (pn_extra, 2) pn_extra => parse_node_get_next_ptr (pn_extra) end if end do end if end subroutine sentry_expr_compile @ %def sentry_expr_compile @ Evaluate the expressions and return an index array of predefined length together with a complex value. If the value (as the last expression) is undefined, set it to unity. If index values are undefined, repeat the previous index value. <>= procedure :: evaluate => sentry_expr_evaluate <>= subroutine sentry_expr_evaluate (sentry, index, value, global) class(sentry_expr_t), intent(inout) :: sentry integer, dimension(:), intent(out) :: index complex(default), intent(out) :: value type(rt_data_t), intent(in), target :: global type(var_list_t), pointer :: var_list integer :: i, n_expr, n_index type(eval_tree_t) :: eval_tree var_list => global%get_var_list_ptr () n_expr = size (sentry%expr) n_index = size (index) if (n_expr <= n_index + 1) then do i = 1, min (n_expr, n_index) associate (expr => sentry%expr(i)) call eval_tree%init_expr (expr%ptr, var_list) call eval_tree%evaluate () if (eval_tree%is_known ()) then index(i) = eval_tree%get_int () else call msg_fatal ("Evaluating density matrix: undefined index") end if end associate end do do i = n_expr + 1, n_index index(i) = index(n_expr) end do if (n_expr == n_index + 1) then associate (expr => sentry%expr(n_expr)) call eval_tree%init_expr (expr%ptr, var_list) call eval_tree%evaluate () if (eval_tree%is_known ()) then value = eval_tree%get_cmplx () else call msg_fatal ("Evaluating density matrix: undefined index") end if call eval_tree%final () end associate else value = 1 end if else call msg_fatal ("Evaluating density matrix: index expression too long") end if end subroutine sentry_expr_evaluate @ %def sentry_expr_evaluate @ The sparse matrix itself consists of an arbitrary number of entries. <>= type :: smatrix_expr_t type(sentry_expr_t), dimension(:), allocatable :: entry contains <> end type smatrix_expr_t @ %def smatrix_expr_t @ Compile: assign sub-nodes to sentry-expressions and compile those. <>= procedure :: compile => smatrix_expr_compile <>= subroutine smatrix_expr_compile (smatrix_expr, pn) class(smatrix_expr_t), intent(out) :: smatrix_expr type(parse_node_t), intent(in), target :: pn type(parse_node_t), pointer :: pn_arg, pn_entry integer :: n_entry, i pn_arg => parse_node_get_sub_ptr (pn, 2) if (associated (pn_arg)) then n_entry = parse_node_get_n_sub (pn_arg) allocate (smatrix_expr%entry (n_entry)) pn_entry => parse_node_get_sub_ptr (pn_arg) do i = 1, n_entry call smatrix_expr%entry(i)%compile (pn_entry) pn_entry => parse_node_get_next_ptr (pn_entry) end do else allocate (smatrix_expr%entry (0)) end if end subroutine smatrix_expr_compile @ %def smatrix_expr_compile @ Evaluate the entries and build a new [[smatrix]] object, which contains just the numerical results. <>= procedure :: evaluate => smatrix_expr_evaluate <>= subroutine smatrix_expr_evaluate (smatrix_expr, smatrix, global) class(smatrix_expr_t), intent(inout) :: smatrix_expr type(smatrix_t), intent(out) :: smatrix type(rt_data_t), intent(in), target :: global integer, dimension(2) :: idx complex(default) :: value integer :: i, n_entry n_entry = size (smatrix_expr%entry) call smatrix%init (2, n_entry) do i = 1, n_entry call smatrix_expr%entry(i)%evaluate (idx, value, global) call smatrix%set_entry (i, idx, value) end do end subroutine smatrix_expr_evaluate @ %def smatrix_expr_evaluate @ \subsubsection{Beam polarization density} The beam polarization command defines spin density matrix for one or two beams (scattering or decay). <>= type, extends (command_t) :: cmd_beams_pol_density_t private integer :: n_in = 0 type(smatrix_expr_t), dimension(:), allocatable :: smatrix contains <> end type cmd_beams_pol_density_t @ %def cmd_beams_pol_density_t @ Output. <>= procedure :: write => cmd_beams_pol_density_write <>= subroutine cmd_beams_pol_density_write (cmd, unit, indent) class(cmd_beams_pol_density_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) select case (cmd%n_in) case (1) write (u, "(1x,A)") "beams polarization setup: 1 [decay]" case (2) write (u, "(1x,A)") "beams polarization setup: 2 [scattering]" case default write (u, "(1x,A)") "beams polarization setup: [undefined]" end select end subroutine cmd_beams_pol_density_write @ %def cmd_beams_pol_density_write @ Compile. Find and assign the parse nodes. Note: local environments are not yet supported. <>= procedure :: compile => cmd_beams_pol_density_compile <>= subroutine cmd_beams_pol_density_compile (cmd, global) class(cmd_beams_pol_density_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_pol_spec, pn_smatrix integer :: i pn_pol_spec => parse_node_get_sub_ptr (cmd%pn, 3) call cmd%compile_options (global) cmd%n_in = parse_node_get_n_sub (pn_pol_spec) allocate (cmd%smatrix (cmd%n_in)) pn_smatrix => parse_node_get_sub_ptr (pn_pol_spec) do i = 1, cmd%n_in call cmd%smatrix(i)%compile (pn_smatrix) pn_smatrix => parse_node_get_next_ptr (pn_smatrix) end do end subroutine cmd_beams_pol_density_compile @ %def cmd_beams_pol_density_compile @ Command execution: Fill polarization density matrices. No check yet, the matrices are checked and normalized when the actual beam object is created, just before integration. For intermediate storage, we use the [[beam_structure]] object in the [[global]] data set. <>= procedure :: execute => cmd_beams_pol_density_execute <>= subroutine cmd_beams_pol_density_execute (cmd, global) class(cmd_beams_pol_density_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(smatrix_t) :: smatrix integer :: i call global%beam_structure%init_pol (cmd%n_in) do i = 1, cmd%n_in call cmd%smatrix(i)%evaluate (smatrix, global) call global%beam_structure%set_smatrix (i, smatrix) end do end subroutine cmd_beams_pol_density_execute @ %def cmd_beams_pol_density_execute @ \subsubsection{Beam polarization fraction} In addition to the polarization density matrix, we can independently specify the polarization fraction for one or both beams. <>= type, extends (command_t) :: cmd_beams_pol_fraction_t private integer :: n_in = 0 type(parse_node_p), dimension(:), allocatable :: expr contains <> end type cmd_beams_pol_fraction_t @ %def cmd_beams_pol_fraction_t @ Output. <>= procedure :: write => cmd_beams_pol_fraction_write <>= subroutine cmd_beams_pol_fraction_write (cmd, unit, indent) class(cmd_beams_pol_fraction_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) select case (cmd%n_in) case (1) write (u, "(1x,A)") "beams polarization fraction: 1 [decay]" case (2) write (u, "(1x,A)") "beams polarization fraction: 2 [scattering]" case default write (u, "(1x,A)") "beams polarization fraction: [undefined]" end select end subroutine cmd_beams_pol_fraction_write @ %def cmd_beams_pol_fraction_write @ Compile. Find and assign the parse nodes. Note: local environments are not yet supported. <>= procedure :: compile => cmd_beams_pol_fraction_compile <>= subroutine cmd_beams_pol_fraction_compile (cmd, global) class(cmd_beams_pol_fraction_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_frac_spec, pn_expr integer :: i pn_frac_spec => parse_node_get_sub_ptr (cmd%pn, 3) call cmd%compile_options (global) cmd%n_in = parse_node_get_n_sub (pn_frac_spec) allocate (cmd%expr (cmd%n_in)) pn_expr => parse_node_get_sub_ptr (pn_frac_spec) do i = 1, cmd%n_in cmd%expr(i)%ptr => pn_expr pn_expr => parse_node_get_next_ptr (pn_expr) end do end subroutine cmd_beams_pol_fraction_compile @ %def cmd_beams_pol_fraction_compile @ Command execution: Retrieve the numerical values of the beam polarization fractions. The results are stored in the [[beam_structure]] component of the [[global]] data block. <>= procedure :: execute => cmd_beams_pol_fraction_execute <>= subroutine cmd_beams_pol_fraction_execute (cmd, global) class(cmd_beams_pol_fraction_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list real(default), dimension(:), allocatable :: pol_f type(eval_tree_t) :: expr integer :: i var_list => global%get_var_list_ptr () allocate (pol_f (cmd%n_in)) do i = 1, cmd%n_in call expr%init_expr (cmd%expr(i)%ptr, var_list) call expr%evaluate () if (expr%is_known ()) then pol_f(i) = expr%get_real () else call msg_fatal ("beams polarization fraction: undefined value") end if call expr%final () end do call global%beam_structure%set_pol_f (pol_f) end subroutine cmd_beams_pol_fraction_execute @ %def cmd_beams_pol_fraction_execute @ \subsubsection{Beam momentum} This is completely analogous to the previous command, hence we can use inheritance. <>= type, extends (cmd_beams_pol_fraction_t) :: cmd_beams_momentum_t contains <> end type cmd_beams_momentum_t @ %def cmd_beams_momentum_t @ Output. <>= procedure :: write => cmd_beams_momentum_write <>= subroutine cmd_beams_momentum_write (cmd, unit, indent) class(cmd_beams_momentum_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) select case (cmd%n_in) case (1) write (u, "(1x,A)") "beams momentum: 1 [decay]" case (2) write (u, "(1x,A)") "beams momentum: 2 [scattering]" case default write (u, "(1x,A)") "beams momentum: [undefined]" end select end subroutine cmd_beams_momentum_write @ %def cmd_beams_momentum_write @ Compile: inherited. Command execution: Not inherited, but just the error string and the final command are changed. <>= procedure :: execute => cmd_beams_momentum_execute <>= subroutine cmd_beams_momentum_execute (cmd, global) class(cmd_beams_momentum_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list real(default), dimension(:), allocatable :: p type(eval_tree_t) :: expr integer :: i var_list => global%get_var_list_ptr () allocate (p (cmd%n_in)) do i = 1, cmd%n_in call expr%init_expr (cmd%expr(i)%ptr, var_list) call expr%evaluate () if (expr%is_known ()) then p(i) = expr%get_real () else call msg_fatal ("beams momentum: undefined value") end if call expr%final () end do call global%beam_structure%set_momentum (p) end subroutine cmd_beams_momentum_execute @ %def cmd_beams_momentum_execute @ \subsubsection{Beam angles} Again, this is analogous. There are two angles, polar angle $\theta$ and azimuthal angle $\phi$, which can be set independently for both beams. <>= type, extends (cmd_beams_pol_fraction_t) :: cmd_beams_theta_t contains <> end type cmd_beams_theta_t type, extends (cmd_beams_pol_fraction_t) :: cmd_beams_phi_t contains <> end type cmd_beams_phi_t @ %def cmd_beams_theta_t @ %def cmd_beams_phi_t @ Output. <>= procedure :: write => cmd_beams_theta_write <>= procedure :: write => cmd_beams_phi_write <>= subroutine cmd_beams_theta_write (cmd, unit, indent) class(cmd_beams_theta_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) select case (cmd%n_in) case (1) write (u, "(1x,A)") "beams theta: 1 [decay]" case (2) write (u, "(1x,A)") "beams theta: 2 [scattering]" case default write (u, "(1x,A)") "beams theta: [undefined]" end select end subroutine cmd_beams_theta_write subroutine cmd_beams_phi_write (cmd, unit, indent) class(cmd_beams_phi_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) select case (cmd%n_in) case (1) write (u, "(1x,A)") "beams phi: 1 [decay]" case (2) write (u, "(1x,A)") "beams phi: 2 [scattering]" case default write (u, "(1x,A)") "beams phi: [undefined]" end select end subroutine cmd_beams_phi_write @ %def cmd_beams_theta_write @ %def cmd_beams_phi_write @ Compile: inherited. Command execution: Not inherited, but just the error string and the final command are changed. <>= procedure :: execute => cmd_beams_theta_execute <>= procedure :: execute => cmd_beams_phi_execute <>= subroutine cmd_beams_theta_execute (cmd, global) class(cmd_beams_theta_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list real(default), dimension(:), allocatable :: theta type(eval_tree_t) :: expr integer :: i var_list => global%get_var_list_ptr () allocate (theta (cmd%n_in)) do i = 1, cmd%n_in call expr%init_expr (cmd%expr(i)%ptr, var_list) call expr%evaluate () if (expr%is_known ()) then theta(i) = expr%get_real () else call msg_fatal ("beams theta: undefined value") end if call expr%final () end do call global%beam_structure%set_theta (theta) end subroutine cmd_beams_theta_execute subroutine cmd_beams_phi_execute (cmd, global) class(cmd_beams_phi_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list real(default), dimension(:), allocatable :: phi type(eval_tree_t) :: expr integer :: i var_list => global%get_var_list_ptr () allocate (phi (cmd%n_in)) do i = 1, cmd%n_in call expr%init_expr (cmd%expr(i)%ptr, var_list) call expr%evaluate () if (expr%is_known ()) then phi(i) = expr%get_real () else call msg_fatal ("beams phi: undefined value") end if call expr%final () end do call global%beam_structure%set_phi (phi) end subroutine cmd_beams_phi_execute @ %def cmd_beams_theta_execute @ %def cmd_beams_phi_execute @ \subsubsection{Cuts} Define a cut expression. We store the parse tree for the right-hand side instead of compiling it. Compilation is deferred to the process environment where the cut expression is used. <>= type, extends (command_t) :: cmd_cuts_t private type(parse_node_t), pointer :: pn_lexpr => null () contains <> end type cmd_cuts_t @ %def cmd_cuts_t @ Output. Do not print the parse tree, since this may get cluttered. Just a message that cuts have been defined. <>= procedure :: write => cmd_cuts_write <>= subroutine cmd_cuts_write (cmd, unit, indent) class(cmd_cuts_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "cuts: [defined]" end subroutine cmd_cuts_write @ %def cmd_cuts_write @ Compile. Simply store the parse (sub)tree. <>= procedure :: compile => cmd_cuts_compile <>= subroutine cmd_cuts_compile (cmd, global) class(cmd_cuts_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global cmd%pn_lexpr => parse_node_get_sub_ptr (cmd%pn, 3) end subroutine cmd_cuts_compile @ %def cmd_cuts_compile @ Instead of evaluating the cut expression, link the parse tree to the global data set, such that it is compiled and executed in the appropriate process context. <>= procedure :: execute => cmd_cuts_execute <>= subroutine cmd_cuts_execute (cmd, global) class(cmd_cuts_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global global%pn%cuts_lexpr => cmd%pn_lexpr end subroutine cmd_cuts_execute @ %def cmd_cuts_execute @ \subsubsection{General, Factorization and Renormalization Scales} Define a scale expression for either the renormalization or the factorization scale. We store the parse tree for the right-hand side instead of compiling it. Compilation is deferred to the process environment where the expression is used. <>= type, extends (command_t) :: cmd_scale_t private type(parse_node_t), pointer :: pn_expr => null () contains <> end type cmd_scale_t @ %def cmd_scale_t <>= type, extends (command_t) :: cmd_fac_scale_t private type(parse_node_t), pointer :: pn_expr => null () contains <> end type cmd_fac_scale_t @ %def cmd_fac_scale_t <>= type, extends (command_t) :: cmd_ren_scale_t private type(parse_node_t), pointer :: pn_expr => null () contains <> end type cmd_ren_scale_t @ %def cmd_ren_scale_t @ Output. Do not print the parse tree, since this may get cluttered. Just a message that scale, renormalization and factorization have been defined, respectively. <>= procedure :: write => cmd_scale_write <>= subroutine cmd_scale_write (cmd, unit, indent) class(cmd_scale_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "scale: [defined]" end subroutine cmd_scale_write @ %def cmd_scale_write @ <>= procedure :: write => cmd_fac_scale_write <>= subroutine cmd_fac_scale_write (cmd, unit, indent) class(cmd_fac_scale_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "factorization scale: [defined]" end subroutine cmd_fac_scale_write @ %def cmd_fac_scale_write @ <>= procedure :: write => cmd_ren_scale_write <>= subroutine cmd_ren_scale_write (cmd, unit, indent) class(cmd_ren_scale_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "renormalization scale: [defined]" end subroutine cmd_ren_scale_write @ %def cmd_ren_scale_write @ Compile. Simply store the parse (sub)tree. <>= procedure :: compile => cmd_scale_compile <>= subroutine cmd_scale_compile (cmd, global) class(cmd_scale_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3) end subroutine cmd_scale_compile @ %def cmd_scale_compile @ <>= procedure :: compile => cmd_fac_scale_compile <>= subroutine cmd_fac_scale_compile (cmd, global) class(cmd_fac_scale_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3) end subroutine cmd_fac_scale_compile @ %def cmd_fac_scale_compile @ <>= procedure :: compile => cmd_ren_scale_compile <>= subroutine cmd_ren_scale_compile (cmd, global) class(cmd_ren_scale_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3) end subroutine cmd_ren_scale_compile @ %def cmd_ren_scale_compile @ Instead of evaluating the scale expression, link the parse tree to the global data set, such that it is compiled and executed in the appropriate process context. <>= procedure :: execute => cmd_scale_execute <>= subroutine cmd_scale_execute (cmd, global) class(cmd_scale_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global global%pn%scale_expr => cmd%pn_expr end subroutine cmd_scale_execute @ %def cmd_scale_execute @ <>= procedure :: execute => cmd_fac_scale_execute <>= subroutine cmd_fac_scale_execute (cmd, global) class(cmd_fac_scale_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global global%pn%fac_scale_expr => cmd%pn_expr end subroutine cmd_fac_scale_execute @ %def cmd_fac_scale_execute @ <>= procedure :: execute => cmd_ren_scale_execute <>= subroutine cmd_ren_scale_execute (cmd, global) class(cmd_ren_scale_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global global%pn%ren_scale_expr => cmd%pn_expr end subroutine cmd_ren_scale_execute @ %def cmd_ren_scale_execute @ \subsubsection{Weight} Define a weight expression. The weight is applied to a process to be integrated, event by event. We store the parse tree for the right-hand side instead of compiling it. Compilation is deferred to the process environment where the expression is used. <>= type, extends (command_t) :: cmd_weight_t private type(parse_node_t), pointer :: pn_expr => null () contains <> end type cmd_weight_t @ %def cmd_weight_t @ Output. Do not print the parse tree, since this may get cluttered. Just a message that scale, renormalization and factorization have been defined, respectively. <>= procedure :: write => cmd_weight_write <>= subroutine cmd_weight_write (cmd, unit, indent) class(cmd_weight_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "weight expression: [defined]" end subroutine cmd_weight_write @ %def cmd_weight_write @ Compile. Simply store the parse (sub)tree. <>= procedure :: compile => cmd_weight_compile <>= subroutine cmd_weight_compile (cmd, global) class(cmd_weight_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3) end subroutine cmd_weight_compile @ %def cmd_weight_compile @ Instead of evaluating the expression, link the parse tree to the global data set, such that it is compiled and executed in the appropriate process context. <>= procedure :: execute => cmd_weight_execute <>= subroutine cmd_weight_execute (cmd, global) class(cmd_weight_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global global%pn%weight_expr => cmd%pn_expr end subroutine cmd_weight_execute @ %def cmd_weight_execute @ \subsubsection{Selection} Define a selection expression. This is to be applied upon simulation or event-file rescanning, event by event. We store the parse tree for the right-hand side instead of compiling it. Compilation is deferred to the environment where the expression is used. <>= type, extends (command_t) :: cmd_selection_t private type(parse_node_t), pointer :: pn_expr => null () contains <> end type cmd_selection_t @ %def cmd_selection_t @ Output. Do not print the parse tree, since this may get cluttered. Just a message that scale, renormalization and factorization have been defined, respectively. <>= procedure :: write => cmd_selection_write <>= subroutine cmd_selection_write (cmd, unit, indent) class(cmd_selection_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "selection expression: [defined]" end subroutine cmd_selection_write @ %def cmd_selection_write @ Compile. Simply store the parse (sub)tree. <>= procedure :: compile => cmd_selection_compile <>= subroutine cmd_selection_compile (cmd, global) class(cmd_selection_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3) end subroutine cmd_selection_compile @ %def cmd_selection_compile @ Instead of evaluating the expression, link the parse tree to the global data set, such that it is compiled and executed in the appropriate process context. <>= procedure :: execute => cmd_selection_execute <>= subroutine cmd_selection_execute (cmd, global) class(cmd_selection_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global global%pn%selection_lexpr => cmd%pn_expr end subroutine cmd_selection_execute @ %def cmd_selection_execute @ \subsubsection{Reweight} Define a reweight expression. This is to be applied upon simulation or event-file rescanning, event by event. We store the parse tree for the right-hand side instead of compiling it. Compilation is deferred to the environment where the expression is used. <>= type, extends (command_t) :: cmd_reweight_t private type(parse_node_t), pointer :: pn_expr => null () contains <> end type cmd_reweight_t @ %def cmd_reweight_t @ Output. Do not print the parse tree, since this may get cluttered. Just a message that scale, renormalization and factorization have been defined, respectively. <>= procedure :: write => cmd_reweight_write <>= subroutine cmd_reweight_write (cmd, unit, indent) class(cmd_reweight_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "reweight expression: [defined]" end subroutine cmd_reweight_write @ %def cmd_reweight_write @ Compile. Simply store the parse (sub)tree. <>= procedure :: compile => cmd_reweight_compile <>= subroutine cmd_reweight_compile (cmd, global) class(cmd_reweight_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3) end subroutine cmd_reweight_compile @ %def cmd_reweight_compile @ Instead of evaluating the expression, link the parse tree to the global data set, such that it is compiled and executed in the appropriate process context. <>= procedure :: execute => cmd_reweight_execute <>= subroutine cmd_reweight_execute (cmd, global) class(cmd_reweight_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global global%pn%reweight_expr => cmd%pn_expr end subroutine cmd_reweight_execute @ %def cmd_reweight_execute @ \subsubsection{Alternative Simulation Setups} Together with simulation, we can re-evaluate event weights in the context of alternative setups. The [[cmd_alt_setup_t]] object is designed to hold these setups, which are brace-enclosed command lists. Compilation is deferred to the simulation environment where the setup expression is used. <>= type, extends (command_t) :: cmd_alt_setup_t private type(parse_node_p), dimension(:), allocatable :: setup contains <> end type cmd_alt_setup_t @ %def cmd_alt_setup_t @ Output. Print just a message that the alternative setup list has been defined. <>= procedure :: write => cmd_alt_setup_write <>= subroutine cmd_alt_setup_write (cmd, unit, indent) class(cmd_alt_setup_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,I0,A)") "alt_setup: ", size (cmd%setup), " entries" end subroutine cmd_alt_setup_write @ %def cmd_alt_setup_write @ Compile. Store the parse sub-trees in an array. <>= procedure :: compile => cmd_alt_setup_compile <>= subroutine cmd_alt_setup_compile (cmd, global) class(cmd_alt_setup_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_list, pn_setup integer :: i pn_list => parse_node_get_sub_ptr (cmd%pn, 3) if (associated (pn_list)) then allocate (cmd%setup (parse_node_get_n_sub (pn_list))) i = 1 pn_setup => parse_node_get_sub_ptr (pn_list) do while (associated (pn_setup)) cmd%setup(i)%ptr => pn_setup i = i + 1 pn_setup => parse_node_get_next_ptr (pn_setup) end do else allocate (cmd%setup (0)) end if end subroutine cmd_alt_setup_compile @ %def cmd_alt_setup_compile @ Execute. Transfer the array of command lists to the global environment. <>= procedure :: execute => cmd_alt_setup_execute <>= subroutine cmd_alt_setup_execute (cmd, global) class(cmd_alt_setup_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global if (allocated (global%pn%alt_setup)) deallocate (global%pn%alt_setup) allocate (global%pn%alt_setup (size (cmd%setup))) global%pn%alt_setup = cmd%setup end subroutine cmd_alt_setup_execute @ %def cmd_alt_setup_execute @ \subsubsection{Integration} Integrate several processes, consecutively with identical parameters. <>= type, extends (command_t) :: cmd_integrate_t private integer :: n_proc = 0 type(string_t), dimension(:), allocatable :: process_id contains <> end type cmd_integrate_t @ %def cmd_integrate_t @ Output: we know the process IDs. <>= procedure :: write => cmd_integrate_write <>= subroutine cmd_integrate_write (cmd, unit, indent) class(cmd_integrate_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, i u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)", advance="no") "integrate (" do i = 1, cmd%n_proc if (i > 1) write (u, "(A,1x)", advance="no") "," write (u, "(A)", advance="no") char (cmd%process_id(i)) end do write (u, "(A)") ")" end subroutine cmd_integrate_write @ %def cmd_integrate_write @ Compile. <>= procedure :: compile => cmd_integrate_compile <>= subroutine cmd_integrate_compile (cmd, global) class(cmd_integrate_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_proclist, pn_proc integer :: i pn_proclist => parse_node_get_sub_ptr (cmd%pn, 2) cmd%pn_opt => parse_node_get_next_ptr (pn_proclist) call cmd%compile_options (global) cmd%n_proc = parse_node_get_n_sub (pn_proclist) allocate (cmd%process_id (cmd%n_proc)) pn_proc => parse_node_get_sub_ptr (pn_proclist) do i = 1, cmd%n_proc cmd%process_id(i) = parse_node_get_string (pn_proc) call global%process_stack%init_result_vars (cmd%process_id(i)) pn_proc => parse_node_get_next_ptr (pn_proc) end do end subroutine cmd_integrate_compile @ %def cmd_integrate_compile @ Command execution. Integrate the process(es) with the predefined number of passes, iterations and calls. For structure functions, cuts, weight and scale, use local definitions if present; by default, the local definitions are initialized with the global ones. The [[integrate]] procedure should take its input from the currently active local environment, but produce a process record in the stack of the global environment. Since the process acquires a snapshot of the variable list, so if the global list (or the local one) is deleted, this does no harm. This implies that later changes of the variable list do not affect the stored process. <>= procedure :: execute => cmd_integrate_execute <>= subroutine cmd_integrate_execute (cmd, global) class(cmd_integrate_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global integer :: i call msg_debug (D_CORE, "cmd_integrate_execute") do i = 1, cmd%n_proc call msg_debug (D_CORE, "cmd%process_id(i) ", cmd%process_id(i)) call integrate_process (cmd%process_id(i), cmd%local, global) call global%process_stack%fill_result_vars (cmd%process_id(i)) call global%process_stack%update_result_vars & (cmd%process_id(i), global%var_list) if (signal_is_pending ()) return end do end subroutine cmd_integrate_execute @ %def cmd_integrate_execute @ \subsubsection{Observables} Declare an observable. After the declaration, it can be used to record data, and at the end one can retrieve average and error. <>= type, extends (command_t) :: cmd_observable_t private type(string_t) :: id contains <> end type cmd_observable_t @ %def cmd_observable_t @ Output. We know the ID. <>= procedure :: write => cmd_observable_write <>= subroutine cmd_observable_write (cmd, unit, indent) class(cmd_observable_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,A)") "observable: ", char (cmd%id) end subroutine cmd_observable_write @ %def cmd_observable_write @ Compile. Just record the observable ID. <>= procedure :: compile => cmd_observable_compile <>= subroutine cmd_observable_compile (cmd, global) class(cmd_observable_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_tag pn_tag => parse_node_get_sub_ptr (cmd%pn, 2) if (associated (pn_tag)) then cmd%pn_opt => parse_node_get_next_ptr (pn_tag) end if call cmd%compile_options (global) select case (char (parse_node_get_rule_key (pn_tag))) case ("analysis_id") cmd%id = parse_node_get_string (pn_tag) case default call msg_bug ("observable: name expression not implemented (yet)") end select end subroutine cmd_observable_compile @ %def cmd_observable_compile @ Command execution. This declares the observable and allocates it in the analysis store. <>= procedure :: execute => cmd_observable_execute <>= subroutine cmd_observable_execute (cmd, global) class(cmd_observable_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(graph_options_t) :: graph_options type(string_t) :: label, unit var_list => cmd%local%get_var_list_ptr () label = var_list%get_sval (var_str ("$obs_label")) unit = var_list%get_sval (var_str ("$obs_unit")) call graph_options_init (graph_options) call set_graph_options (graph_options, var_list) call analysis_init_observable (cmd%id, label, unit, graph_options) end subroutine cmd_observable_execute @ %def cmd_observable_execute @ \subsubsection{Histograms} Declare a histogram. At minimum, we have to set lower and upper bound and bin width. <>= type, extends (command_t) :: cmd_histogram_t private type(string_t) :: id type(parse_node_t), pointer :: pn_lower_bound => null () type(parse_node_t), pointer :: pn_upper_bound => null () type(parse_node_t), pointer :: pn_bin_width => null () contains <> end type cmd_histogram_t @ %def cmd_histogram_t @ Output. Just print the ID. <>= procedure :: write => cmd_histogram_write <>= subroutine cmd_histogram_write (cmd, unit, indent) class(cmd_histogram_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,A)") "histogram: ", char (cmd%id) end subroutine cmd_histogram_write @ %def cmd_histogram_write @ Compile. Record the histogram ID and initialize lower, upper bound and bin width. <>= procedure :: compile => cmd_histogram_compile <>= subroutine cmd_histogram_compile (cmd, global) class(cmd_histogram_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_tag, pn_args, pn_arg1, pn_arg2, pn_arg3 character(*), parameter :: e_illegal_use = & "illegal usage of 'histogram': insufficient number of arguments" pn_tag => parse_node_get_sub_ptr (cmd%pn, 2) pn_args => parse_node_get_next_ptr (pn_tag) if (associated (pn_args)) then pn_arg1 => parse_node_get_sub_ptr (pn_args) if (.not. associated (pn_arg1)) call msg_fatal (e_illegal_use) pn_arg2 => parse_node_get_next_ptr (pn_arg1) if (.not. associated (pn_arg2)) call msg_fatal (e_illegal_use) pn_arg3 => parse_node_get_next_ptr (pn_arg2) cmd%pn_opt => parse_node_get_next_ptr (pn_args) end if call cmd%compile_options (global) select case (char (parse_node_get_rule_key (pn_tag))) case ("analysis_id") cmd%id = parse_node_get_string (pn_tag) case default call msg_bug ("histogram: name expression not implemented (yet)") end select cmd%pn_lower_bound => pn_arg1 cmd%pn_upper_bound => pn_arg2 cmd%pn_bin_width => pn_arg3 end subroutine cmd_histogram_compile @ %def cmd_histogram_compile @ Command execution. This declares the histogram and allocates it in the analysis store. <>= procedure :: execute => cmd_histogram_execute <>= subroutine cmd_histogram_execute (cmd, global) class(cmd_histogram_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list real(default) :: lower_bound, upper_bound, bin_width integer :: bin_number logical :: bin_width_is_used, normalize_bins type(string_t) :: obs_label, obs_unit type(graph_options_t) :: graph_options type(drawing_options_t) :: drawing_options var_list => cmd%local%get_var_list_ptr () lower_bound = eval_real (cmd%pn_lower_bound, var_list) upper_bound = eval_real (cmd%pn_upper_bound, var_list) if (associated (cmd%pn_bin_width)) then bin_width = eval_real (cmd%pn_bin_width, var_list) bin_width_is_used = .true. else if (var_list%is_known (var_str ("n_bins"))) then bin_number = & var_list%get_ival (var_str ("n_bins")) bin_width_is_used = .false. else call msg_error ("Cmd '" // char (cmd%id) // & "': neither bin width nor number is defined") end if normalize_bins = & var_list%get_lval (var_str ("?normalize_bins")) obs_label = & var_list%get_sval (var_str ("$obs_label")) obs_unit = & var_list%get_sval (var_str ("$obs_unit")) call graph_options_init (graph_options) call set_graph_options (graph_options, var_list) call drawing_options_init_histogram (drawing_options) call set_drawing_options (drawing_options, var_list) if (bin_width_is_used) then call analysis_init_histogram & (cmd%id, lower_bound, upper_bound, bin_width, & normalize_bins, & obs_label, obs_unit, & graph_options, drawing_options) else call analysis_init_histogram & (cmd%id, lower_bound, upper_bound, bin_number, & normalize_bins, & obs_label, obs_unit, & graph_options, drawing_options) end if end subroutine cmd_histogram_execute @ %def cmd_histogram_execute @ Set the graph options from a variable list. <>= subroutine set_graph_options (gro, var_list) type(graph_options_t), intent(inout) :: gro type(var_list_t), intent(in) :: var_list call graph_options_set (gro, title = & var_list%get_sval (var_str ("$title"))) call graph_options_set (gro, description = & var_list%get_sval (var_str ("$description"))) call graph_options_set (gro, x_label = & var_list%get_sval (var_str ("$x_label"))) call graph_options_set (gro, y_label = & var_list%get_sval (var_str ("$y_label"))) call graph_options_set (gro, width_mm = & var_list%get_ival (var_str ("graph_width_mm"))) call graph_options_set (gro, height_mm = & var_list%get_ival (var_str ("graph_height_mm"))) call graph_options_set (gro, x_log = & var_list%get_lval (var_str ("?x_log"))) call graph_options_set (gro, y_log = & var_list%get_lval (var_str ("?y_log"))) if (var_list%is_known (var_str ("x_min"))) & call graph_options_set (gro, x_min = & var_list%get_rval (var_str ("x_min"))) if (var_list%is_known (var_str ("x_max"))) & call graph_options_set (gro, x_max = & var_list%get_rval (var_str ("x_max"))) if (var_list%is_known (var_str ("y_min"))) & call graph_options_set (gro, y_min = & var_list%get_rval (var_str ("y_min"))) if (var_list%is_known (var_str ("y_max"))) & call graph_options_set (gro, y_max = & var_list%get_rval (var_str ("y_max"))) call graph_options_set (gro, gmlcode_bg = & var_list%get_sval (var_str ("$gmlcode_bg"))) call graph_options_set (gro, gmlcode_fg = & var_list%get_sval (var_str ("$gmlcode_fg"))) end subroutine set_graph_options @ %def set_graph_options @ Set the drawing options from a variable list. <>= subroutine set_drawing_options (dro, var_list) type(drawing_options_t), intent(inout) :: dro type(var_list_t), intent(in) :: var_list if (var_list%is_known (var_str ("?draw_histogram"))) then if (var_list%get_lval (var_str ("?draw_histogram"))) then call drawing_options_set (dro, with_hbars = .true.) else call drawing_options_set (dro, with_hbars = .false., & with_base = .false., fill = .false., piecewise = .false.) end if end if if (var_list%is_known (var_str ("?draw_base"))) then if (var_list%get_lval (var_str ("?draw_base"))) then call drawing_options_set (dro, with_base = .true.) else call drawing_options_set (dro, with_base = .false., fill = .false.) end if end if if (var_list%is_known (var_str ("?draw_piecewise"))) then if (var_list%get_lval (var_str ("?draw_piecewise"))) then call drawing_options_set (dro, piecewise = .true.) else call drawing_options_set (dro, piecewise = .false.) end if end if if (var_list%is_known (var_str ("?fill_curve"))) then if (var_list%get_lval (var_str ("?fill_curve"))) then call drawing_options_set (dro, fill = .true., with_base = .true.) else call drawing_options_set (dro, fill = .false.) end if end if if (var_list%is_known (var_str ("?draw_curve"))) then if (var_list%get_lval (var_str ("?draw_curve"))) then call drawing_options_set (dro, draw = .true.) else call drawing_options_set (dro, draw = .false.) end if end if if (var_list%is_known (var_str ("?draw_errors"))) then if (var_list%get_lval (var_str ("?draw_errors"))) then call drawing_options_set (dro, err = .true.) else call drawing_options_set (dro, err = .false.) end if end if if (var_list%is_known (var_str ("?draw_symbols"))) then if (var_list%get_lval (var_str ("?draw_symbols"))) then call drawing_options_set (dro, symbols = .true.) else call drawing_options_set (dro, symbols = .false.) end if end if if (var_list%is_known (var_str ("$fill_options"))) then call drawing_options_set (dro, fill_options = & var_list%get_sval (var_str ("$fill_options"))) end if if (var_list%is_known (var_str ("$draw_options"))) then call drawing_options_set (dro, draw_options = & var_list%get_sval (var_str ("$draw_options"))) end if if (var_list%is_known (var_str ("$err_options"))) then call drawing_options_set (dro, err_options = & var_list%get_sval (var_str ("$err_options"))) end if if (var_list%is_known (var_str ("$symbol"))) then call drawing_options_set (dro, symbol = & var_list%get_sval (var_str ("$symbol"))) end if if (var_list%is_known (var_str ("$gmlcode_bg"))) then call drawing_options_set (dro, gmlcode_bg = & var_list%get_sval (var_str ("$gmlcode_bg"))) end if if (var_list%is_known (var_str ("$gmlcode_fg"))) then call drawing_options_set (dro, gmlcode_fg = & var_list%get_sval (var_str ("$gmlcode_fg"))) end if end subroutine set_drawing_options @ %def set_drawing_options @ \subsubsection{Plots} Declare a plot. No mandatory arguments, just options. <>= type, extends (command_t) :: cmd_plot_t private type(string_t) :: id contains <> end type cmd_plot_t @ %def cmd_plot_t @ Output. Just print the ID. <>= procedure :: write => cmd_plot_write <>= subroutine cmd_plot_write (cmd, unit, indent) class(cmd_plot_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,A)") "plot: ", char (cmd%id) end subroutine cmd_plot_write @ %def cmd_plot_write @ Compile. Record the plot ID and initialize lower, upper bound and bin width. <>= procedure :: compile => cmd_plot_compile <>= subroutine cmd_plot_compile (cmd, global) class(cmd_plot_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_tag pn_tag => parse_node_get_sub_ptr (cmd%pn, 2) cmd%pn_opt => parse_node_get_next_ptr (pn_tag) call cmd%init (pn_tag, global) end subroutine cmd_plot_compile @ %def cmd_plot_compile @ This init routine is separated because it is reused below for graph initialization. <>= procedure :: init => cmd_plot_init <>= subroutine cmd_plot_init (plot, pn_tag, global) class(cmd_plot_t), intent(inout) :: plot type(parse_node_t), intent(in), pointer :: pn_tag type(rt_data_t), intent(inout), target :: global call plot%compile_options (global) select case (char (parse_node_get_rule_key (pn_tag))) case ("analysis_id") plot%id = parse_node_get_string (pn_tag) case default call msg_bug ("plot: name expression not implemented (yet)") end select end subroutine cmd_plot_init @ %def cmd_plot_init @ Command execution. This declares the plot and allocates it in the analysis store. <>= procedure :: execute => cmd_plot_execute <>= subroutine cmd_plot_execute (cmd, global) class(cmd_plot_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(graph_options_t) :: graph_options type(drawing_options_t) :: drawing_options var_list => cmd%local%get_var_list_ptr () call graph_options_init (graph_options) call set_graph_options (graph_options, var_list) call drawing_options_init_plot (drawing_options) call set_drawing_options (drawing_options, var_list) call analysis_init_plot (cmd%id, graph_options, drawing_options) end subroutine cmd_plot_execute @ %def cmd_plot_execute @ \subsubsection{Graphs} Declare a graph. The graph is defined in terms of its contents. Both the graph and its contents may carry options. The graph object contains its own ID as well as the IDs of its elements. For the elements, we reuse the [[cmd_plot_t]] defined above. <>= type, extends (command_t) :: cmd_graph_t private type(string_t) :: id integer :: n_elements = 0 type(cmd_plot_t), dimension(:), allocatable :: el type(string_t), dimension(:), allocatable :: element_id contains <> end type cmd_graph_t @ %def cmd_graph_t @ Output. Just print the ID. <>= procedure :: write => cmd_graph_write <>= subroutine cmd_graph_write (cmd, unit, indent) class(cmd_graph_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,A,A,I0,A)") "graph: ", char (cmd%id), & " (", cmd%n_elements, " entries)" end subroutine cmd_graph_write @ %def cmd_graph_write @ Compile. Record the graph ID and initialize lower, upper bound and bin width. For compiling the graph element syntax, we use part of the [[cmd_plot_t]] compiler. Note: currently, we do not respect options, therefore just IDs on the RHS. <>= procedure :: compile => cmd_graph_compile <>= subroutine cmd_graph_compile (cmd, global) class(cmd_graph_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_term, pn_tag, pn_def, pn_app integer :: i pn_term => parse_node_get_sub_ptr (cmd%pn, 2) pn_tag => parse_node_get_sub_ptr (pn_term) cmd%pn_opt => parse_node_get_next_ptr (pn_tag) call cmd%compile_options (global) select case (char (parse_node_get_rule_key (pn_tag))) case ("analysis_id") cmd%id = parse_node_get_string (pn_tag) case default call msg_bug ("graph: name expression not implemented (yet)") end select pn_def => parse_node_get_next_ptr (pn_term, 2) cmd%n_elements = parse_node_get_n_sub (pn_def) allocate (cmd%element_id (cmd%n_elements)) allocate (cmd%el (cmd%n_elements)) pn_term => parse_node_get_sub_ptr (pn_def) pn_tag => parse_node_get_sub_ptr (pn_term) cmd%el(1)%pn_opt => parse_node_get_next_ptr (pn_tag) call cmd%el(1)%init (pn_tag, global) cmd%element_id(1) = parse_node_get_string (pn_tag) pn_app => parse_node_get_next_ptr (pn_term) do i = 2, cmd%n_elements pn_term => parse_node_get_sub_ptr (pn_app, 2) pn_tag => parse_node_get_sub_ptr (pn_term) cmd%el(i)%pn_opt => parse_node_get_next_ptr (pn_tag) call cmd%el(i)%init (pn_tag, global) cmd%element_id(i) = parse_node_get_string (pn_tag) pn_app => parse_node_get_next_ptr (pn_app) end do end subroutine cmd_graph_compile @ %def cmd_graph_compile @ Command execution. This declares the graph, allocates it in the analysis store, and copies the graph elements. For the graph, we set graph and default drawing options. For the elements, we reset individual drawing options. This accesses internals of the contained elements of type [[cmd_plot_t]], see above. We might disentangle such an interdependency when this code is rewritten using proper type extension. <>= procedure :: execute => cmd_graph_execute <>= subroutine cmd_graph_execute (cmd, global) class(cmd_graph_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(graph_options_t) :: graph_options type(drawing_options_t) :: drawing_options integer :: i, type var_list => cmd%local%get_var_list_ptr () call graph_options_init (graph_options) call set_graph_options (graph_options, var_list) call analysis_init_graph (cmd%id, cmd%n_elements, graph_options) do i = 1, cmd%n_elements if (associated (cmd%el(i)%options)) then call cmd%el(i)%options%execute (cmd%el(i)%local) end if type = analysis_store_get_object_type (cmd%element_id(i)) select case (type) case (AN_HISTOGRAM) call drawing_options_init_histogram (drawing_options) case (AN_PLOT) call drawing_options_init_plot (drawing_options) end select call set_drawing_options (drawing_options, var_list) if (associated (cmd%el(i)%options)) then call set_drawing_options (drawing_options, cmd%el(i)%local%var_list) end if call analysis_fill_graph (cmd%id, i, cmd%element_id(i), drawing_options) end do end subroutine cmd_graph_execute @ %def cmd_graph_execute @ \subsubsection{Analysis} Hold the analysis ID either as a string or as an expression: <>= type :: analysis_id_t type(string_t) :: tag type(parse_node_t), pointer :: pn_sexpr => null () end type analysis_id_t @ %def analysis_id_t @ Define the analysis expression. We store the parse tree for the right-hand side instead of compiling it. Compilation is deferred to the process environment where the analysis expression is used. <>= type, extends (command_t) :: cmd_analysis_t private type(parse_node_t), pointer :: pn_lexpr => null () contains <> end type cmd_analysis_t @ %def cmd_analysis_t @ Output. Print just a message that analysis has been defined. <>= procedure :: write => cmd_analysis_write <>= subroutine cmd_analysis_write (cmd, unit, indent) class(cmd_analysis_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "analysis: [defined]" end subroutine cmd_analysis_write @ %def cmd_analysis_write @ Compile. Simply store the parse (sub)tree. <>= procedure :: compile => cmd_analysis_compile <>= subroutine cmd_analysis_compile (cmd, global) class(cmd_analysis_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global cmd%pn_lexpr => parse_node_get_sub_ptr (cmd%pn, 3) end subroutine cmd_analysis_compile @ %def cmd_analysis_compile @ Instead of evaluating the cut expression, link the parse tree to the global data set, such that it is compiled and executed in the appropriate process context. <>= procedure :: execute => cmd_analysis_execute <>= subroutine cmd_analysis_execute (cmd, global) class(cmd_analysis_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global global%pn%analysis_lexpr => cmd%pn_lexpr end subroutine cmd_analysis_execute @ %def cmd_analysis_execute @ \subsubsection{Write histograms and plots} The data type encapsulating the command: <>= type, extends (command_t) :: cmd_write_analysis_t private type(analysis_id_t), dimension(:), allocatable :: id type(string_t), dimension(:), allocatable :: tag contains <> end type cmd_write_analysis_t @ %def analysis_id_t @ %def cmd_write_analysis_t @ Output. Just the keyword. <>= procedure :: write => cmd_write_analysis_write <>= subroutine cmd_write_analysis_write (cmd, unit, indent) class(cmd_write_analysis_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "write_analysis" end subroutine cmd_write_analysis_write @ %def cmd_write_analysis_write @ Compile. <>= procedure :: compile => cmd_write_analysis_compile <>= subroutine cmd_write_analysis_compile (cmd, global) class(cmd_write_analysis_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_clause, pn_args, pn_id integer :: n, i pn_clause => parse_node_get_sub_ptr (cmd%pn) pn_args => parse_node_get_sub_ptr (pn_clause, 2) cmd%pn_opt => parse_node_get_next_ptr (pn_clause) call cmd%compile_options (global) if (associated (pn_args)) then n = parse_node_get_n_sub (pn_args) allocate (cmd%id (n)) do i = 1, n pn_id => parse_node_get_sub_ptr (pn_args, i) if (char (parse_node_get_rule_key (pn_id)) == "analysis_id") then cmd%id(i)%tag = parse_node_get_string (pn_id) else cmd%id(i)%pn_sexpr => pn_id end if end do else allocate (cmd%id (0)) end if end subroutine cmd_write_analysis_compile @ %def cmd_write_analysis_compile @ The output format for real data values: <>= character(*), parameter, public :: & DEFAULT_ANALYSIS_FILENAME = "whizard_analysis.dat" character(len=1), dimension(2), parameter, public :: & FORBIDDEN_ENDINGS1 = [ "o", "a" ] character(len=2), dimension(6), parameter, public :: & FORBIDDEN_ENDINGS2 = [ "mp", "ps", "vg", "pg", "lo", "la" ] character(len=3), dimension(16), parameter, public :: & FORBIDDEN_ENDINGS3 = [ "aux", "dvi", "evt", "evx", "f03", "f90", & "f95", "log", "ltp", "mpx", "olc", "olp", "pdf", "phs", "sin", "tex" ] @ %def DEFAULT_ANALYSIS_FILENAME @ %def FORBIDDEN_ENDINGS1 @ %def FORBIDDEN_ENDINGS2 @ %def FORBIDDEN_ENDINGS3 @ As this contains a lot of similar code to [[cmd_compile_analysis_execute]] we outsource the main code to a subroutine. <>= procedure :: execute => cmd_write_analysis_execute <>= subroutine cmd_write_analysis_execute (cmd, global) class(cmd_write_analysis_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list var_list => cmd%local%get_var_list_ptr () call write_analysis_wrap (var_list, global%out_files, & cmd%id, tag = cmd%tag) end subroutine cmd_write_analysis_execute @ %def cmd_write_analysis_execute @ If the [[data_file]] optional argument is present, this is called from [[cmd_compile_analysis_execute]], which needs the file name for further processing, and requires the default format. For the moment, parameters and macros for custom data processing are disabled. <>= subroutine write_analysis_wrap (var_list, out_files, id, tag, data_file) type(var_list_t), intent(inout), target :: var_list type(file_list_t), intent(inout), target :: out_files type(analysis_id_t), dimension(:), intent(in), target :: id type(string_t), dimension(:), allocatable, intent(out) :: tag type(string_t), intent(out), optional :: data_file type(string_t) :: defaultfile, file integer :: i logical :: keep_open !, custom, header, columns type(string_t) :: extension !, comment_prefix, separator !!! JRR: WK please check (#542) ! integer :: type ! type(ifile_t) :: ifile logical :: one_file !, has_writer ! type(analysis_iterator_t) :: iterator ! type(rt_data_t), target :: sandbox ! type(command_list_t) :: writer defaultfile = var_list%get_sval (var_str ("$out_file")) if (present (data_file)) then if (defaultfile == "" .or. defaultfile == ".") then defaultfile = DEFAULT_ANALYSIS_FILENAME else if (scan (".", defaultfile) > 0) then call split (defaultfile, extension, ".", back=.true.) if (any (lower_case (char(extension)) == FORBIDDEN_ENDINGS1) .or. & any (lower_case (char(extension)) == FORBIDDEN_ENDINGS2) .or. & any (lower_case (char(extension)) == FORBIDDEN_ENDINGS3)) & call msg_fatal ("The ending " // char(extension) // & " is internal and not allowed as data file.") if (extension /= "") then if (defaultfile /= "") then defaultfile = defaultfile // "." // extension else defaultfile = "whizard_analysis." // extension end if else defaultfile = defaultfile // ".dat" endif else defaultfile = defaultfile // ".dat" end if end if data_file = defaultfile end if one_file = defaultfile /= "" if (one_file) then file = defaultfile keep_open = file_list_is_open (out_files, file, & action = "write") if (keep_open) then if (present (data_file)) then call msg_fatal ("Compiling analysis: File '" & // char (data_file) & // "' can't be used, it is already open.") else call msg_message ("Appending analysis data to file '" & // char (file) // "'") end if else call file_list_open (out_files, file, & action = "write", status = "replace", position = "asis") call msg_message ("Writing analysis data to file '" & // char (file) // "'") end if end if !!! JRR: WK please check. Custom data output. Ticket #542 ! if (present (data_file)) then ! custom = .false. ! else ! custom = var_list%get_lval (& ! var_str ("?out_custom")) ! end if ! comment_prefix = var_list%get_sval (& ! var_str ("$out_comment")) ! header = var_list%get_lval (& ! var_str ("?out_header")) ! write_yerr = var_list%get_lval (& ! var_str ("?out_yerr")) ! write_xerr = var_list%get_lval (& ! var_str ("?out_xerr")) call get_analysis_tags (tag, id, var_list) do i = 1, size (tag) call file_list_write_analysis & (out_files, file, tag(i)) end do if (one_file .and. .not. keep_open) then call file_list_close (out_files, file) end if contains subroutine get_analysis_tags (analysis_tag, id, var_list) type(string_t), dimension(:), intent(out), allocatable :: analysis_tag type(analysis_id_t), dimension(:), intent(in) :: id type(var_list_t), intent(in), target :: var_list if (size (id) /= 0) then allocate (analysis_tag (size (id))) do i = 1, size (id) if (associated (id(i)%pn_sexpr)) then analysis_tag(i) = eval_string (id(i)%pn_sexpr, var_list) else analysis_tag(i) = id(i)%tag end if end do else call analysis_store_get_ids (tag) end if end subroutine get_analysis_tags end subroutine write_analysis_wrap @ %def write_analysis_wrap \subsubsection{Compile analysis results} This command writes files in a form suitable for GAMELAN and executes the appropriate commands to compile them. The first part is identical to [[cmd_write_analysis]]. <>= type, extends (command_t) :: cmd_compile_analysis_t private type(analysis_id_t), dimension(:), allocatable :: id type(string_t), dimension(:), allocatable :: tag contains <> end type cmd_compile_analysis_t @ %def cmd_compile_analysis_t @ Output. Just the keyword. <>= procedure :: write => cmd_compile_analysis_write <>= subroutine cmd_compile_analysis_write (cmd, unit, indent) class(cmd_compile_analysis_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "compile_analysis" end subroutine cmd_compile_analysis_write @ %def cmd_compile_analysis_write @ Compile. <>= procedure :: compile => cmd_compile_analysis_compile <>= subroutine cmd_compile_analysis_compile (cmd, global) class(cmd_compile_analysis_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_clause, pn_args, pn_id integer :: n, i pn_clause => parse_node_get_sub_ptr (cmd%pn) pn_args => parse_node_get_sub_ptr (pn_clause, 2) cmd%pn_opt => parse_node_get_next_ptr (pn_clause) call cmd%compile_options (global) if (associated (pn_args)) then n = parse_node_get_n_sub (pn_args) allocate (cmd%id (n)) do i = 1, n pn_id => parse_node_get_sub_ptr (pn_args, i) if (char (parse_node_get_rule_key (pn_id)) == "analysis_id") then cmd%id(i)%tag = parse_node_get_string (pn_id) else cmd%id(i)%pn_sexpr => pn_id end if end do else allocate (cmd%id (0)) end if end subroutine cmd_compile_analysis_compile @ %def cmd_compile_analysis_compile @ First write the analysis data to file, then write a GAMELAN driver and produce MetaPost and \TeX\ output. <>= procedure :: execute => cmd_compile_analysis_execute <>= subroutine cmd_compile_analysis_execute (cmd, global) class(cmd_compile_analysis_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(string_t) :: file, basename, extension, driver_file, & makefile integer :: u_driver, u_makefile logical :: has_gmlcode, only_file var_list => cmd%local%get_var_list_ptr () call write_analysis_wrap (var_list, & global%out_files, cmd%id, tag = cmd%tag, & data_file = file) basename = file if (scan (".", basename) > 0) then call split (basename, extension, ".", back=.true.) else extension = "" end if driver_file = basename // ".tex" makefile = basename // "_ana.makefile" u_driver = free_unit () open (unit=u_driver, file=char(driver_file), & action="write", status="replace") if (allocated (cmd%tag)) then call analysis_write_driver (file, cmd%tag, unit=u_driver) has_gmlcode = analysis_has_plots (cmd%tag) else call analysis_write_driver (file, unit=u_driver) has_gmlcode = analysis_has_plots () end if close (u_driver) u_makefile = free_unit () open (unit=u_makefile, file=char(makefile), & action="write", status="replace") call analysis_write_makefile (basename, u_makefile, & has_gmlcode, global%os_data) close (u_makefile) call msg_message ("Compiling analysis results display in '" & // char (driver_file) // "'") call msg_message ("Providing analysis steering makefile '" & // char (makefile) // "'") only_file = global%var_list%get_lval & (var_str ("?analysis_file_only")) if (.not. only_file) call analysis_compile_tex & (basename, has_gmlcode, global%os_data) end subroutine cmd_compile_analysis_execute @ %def cmd_compile_analysis_execute @ \subsection{User-controlled output to data files} \subsubsection{Open file (output)} Open a file for output. <>= type, extends (command_t) :: cmd_open_out_t private type(parse_node_t), pointer :: file_expr => null () contains <> end type cmd_open_out_t @ %def cmd_open_out @ Finalizer for the embedded eval tree. <>= subroutine cmd_open_out_final (object) class(cmd_open_out_t), intent(inout) :: object end subroutine cmd_open_out_final @ %def cmd_open_out_final @ Output (trivial here). <>= procedure :: write => cmd_open_out_write <>= subroutine cmd_open_out_write (cmd, unit, indent) class(cmd_open_out_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)", advance="no") "open_out: " end subroutine cmd_open_out_write @ %def cmd_open_out_write @ Compile: create an eval tree for the filename expression. <>= procedure :: compile => cmd_open_out_compile <>= subroutine cmd_open_out_compile (cmd, global) class(cmd_open_out_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global cmd%file_expr => parse_node_get_sub_ptr (cmd%pn, 2) if (associated (cmd%file_expr)) then cmd%pn_opt => parse_node_get_next_ptr (cmd%file_expr) end if call cmd%compile_options (global) end subroutine cmd_open_out_compile @ %def cmd_open_out_compile @ Execute: append the file to the global list of open files. <>= procedure :: execute => cmd_open_out_execute <>= subroutine cmd_open_out_execute (cmd, global) class(cmd_open_out_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(eval_tree_t) :: file_expr type(string_t) :: file var_list => cmd%local%get_var_list_ptr () call file_expr%init_sexpr (cmd%file_expr, var_list) call file_expr%evaluate () if (file_expr%is_known ()) then file = file_expr%get_string () call file_list_open (global%out_files, file, & action = "write", status = "replace", position = "asis") else call msg_fatal ("open_out: file name argument evaluates to unknown") end if call file_expr%final () end subroutine cmd_open_out_execute @ %def cmd_open_out_execute \subsubsection{Open file (output)} Close an output file. Except for the [[execute]] method, everything is analogous to the open command, so we can just inherit. <>= type, extends (cmd_open_out_t) :: cmd_close_out_t private contains <> end type cmd_close_out_t @ %def cmd_close_out @ Execute: remove the file from the global list of output files. <>= procedure :: execute => cmd_close_out_execute <>= subroutine cmd_close_out_execute (cmd, global) class(cmd_close_out_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(eval_tree_t) :: file_expr type(string_t) :: file var_list => cmd%local%var_list call file_expr%init_sexpr (cmd%file_expr, var_list) call file_expr%evaluate () if (file_expr%is_known ()) then file = file_expr%get_string () call file_list_close (global%out_files, file) else call msg_fatal ("close_out: file name argument evaluates to unknown") end if call file_expr%final () end subroutine cmd_close_out_execute @ %def cmd_close_out_execute @ \subsection{Print custom-formatted values} <>= type, extends (command_t) :: cmd_printf_t private type(parse_node_t), pointer :: sexpr => null () type(parse_node_t), pointer :: sprintf_fun => null () type(parse_node_t), pointer :: sprintf_clause => null () type(parse_node_t), pointer :: sprintf => null () contains <> end type cmd_printf_t @ %def cmd_printf_t @ Finalize. <>= procedure :: final => cmd_printf_final <>= subroutine cmd_printf_final (cmd) class(cmd_printf_t), intent(inout) :: cmd call parse_node_final (cmd%sexpr, recursive = .false.) deallocate (cmd%sexpr) call parse_node_final (cmd%sprintf_fun, recursive = .false.) deallocate (cmd%sprintf_fun) call parse_node_final (cmd%sprintf_clause, recursive = .false.) deallocate (cmd%sprintf_clause) call parse_node_final (cmd%sprintf, recursive = .false.) deallocate (cmd%sprintf) end subroutine cmd_printf_final @ %def cmd_printf_final @ Output. Do not print the parse tree, since this may get cluttered. Just a message that cuts have been defined. <>= procedure :: write => cmd_printf_write <>= subroutine cmd_printf_write (cmd, unit, indent) class(cmd_printf_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "printf:" end subroutine cmd_printf_write @ %def cmd_printf_write @ Compile. We create a fake parse node (subtree) with a [[sprintf]] command with identical arguments which can then be handled by the corresponding evaluation procedure. <>= procedure :: compile => cmd_printf_compile <>= subroutine cmd_printf_compile (cmd, global) class(cmd_printf_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_cmd, pn_clause, pn_args, pn_format pn_cmd => parse_node_get_sub_ptr (cmd%pn) pn_clause => parse_node_get_sub_ptr (pn_cmd) pn_format => parse_node_get_sub_ptr (pn_clause, 2) pn_args => parse_node_get_next_ptr (pn_clause) cmd%pn_opt => parse_node_get_next_ptr (pn_cmd) call cmd%compile_options (global) allocate (cmd%sexpr) call parse_node_create_branch (cmd%sexpr, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("sexpr"))) allocate (cmd%sprintf_fun) call parse_node_create_branch (cmd%sprintf_fun, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("sprintf_fun"))) allocate (cmd%sprintf_clause) call parse_node_create_branch (cmd%sprintf_clause, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("sprintf_clause"))) allocate (cmd%sprintf) call parse_node_create_key (cmd%sprintf, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("sprintf"))) call parse_node_append_sub (cmd%sprintf_clause, cmd%sprintf) call parse_node_append_sub (cmd%sprintf_clause, pn_format) call parse_node_freeze_branch (cmd%sprintf_clause) call parse_node_append_sub (cmd%sprintf_fun, cmd%sprintf_clause) if (associated (pn_args)) then call parse_node_append_sub (cmd%sprintf_fun, pn_args) end if call parse_node_freeze_branch (cmd%sprintf_fun) call parse_node_append_sub (cmd%sexpr, cmd%sprintf_fun) call parse_node_freeze_branch (cmd%sexpr) end subroutine cmd_printf_compile @ %def cmd_printf_compile @ Execute. Evaluate the string (pretending this is a [[sprintf]] expression) and print it. <>= procedure :: execute => cmd_printf_execute <>= subroutine cmd_printf_execute (cmd, global) class(cmd_printf_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(string_t) :: string, file type(eval_tree_t) :: sprintf_expr logical :: advance var_list => cmd%local%get_var_list_ptr () advance = var_list%get_lval (& var_str ("?out_advance")) file = var_list%get_sval (& var_str ("$out_file")) call sprintf_expr%init_sexpr (cmd%sexpr, var_list) call sprintf_expr%evaluate () if (sprintf_expr%is_known ()) then string = sprintf_expr%get_string () if (len (file) == 0) then call msg_result (char (string)) else call file_list_write (global%out_files, file, string, advance) end if end if end subroutine cmd_printf_execute @ %def cmd_printf_execute @ \subsubsection{Record data} The expression syntax already contains a [[record]] keyword; this evaluates to a logical which is always true, but it has the side-effect of recording data into analysis objects. Here we define a command as an interface to this construct. <>= type, extends (command_t) :: cmd_record_t private type(parse_node_t), pointer :: pn_lexpr => null () contains <> end type cmd_record_t @ %def cmd_record_t @ Output. With the compile hack below, there is nothing of interest to print here. <>= procedure :: write => cmd_record_write <>= subroutine cmd_record_write (cmd, unit, indent) class(cmd_record_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)") "record" end subroutine cmd_record_write @ %def cmd_record_write @ Compile. This is a hack which transforms the [[record]] command into a [[record]] expression, which we handle in the [[expressions]] module. <>= procedure :: compile => cmd_record_compile <>= subroutine cmd_record_compile (cmd, global) class(cmd_record_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_lexpr, pn_lsinglet, pn_lterm, pn_record call parse_node_create_branch (pn_lexpr, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("lexpr"))) call parse_node_create_branch (pn_lsinglet, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("lsinglet"))) call parse_node_append_sub (pn_lexpr, pn_lsinglet) call parse_node_create_branch (pn_lterm, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("lterm"))) call parse_node_append_sub (pn_lsinglet, pn_lterm) pn_record => parse_node_get_sub_ptr (cmd%pn) call parse_node_append_sub (pn_lterm, pn_record) cmd%pn_lexpr => pn_lexpr end subroutine cmd_record_compile @ %def cmd_record_compile @ Command execution. Again, transfer this to the embedded expression and just forget the logical result. <>= procedure :: execute => cmd_record_execute <>= subroutine cmd_record_execute (cmd, global) class(cmd_record_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list logical :: lval var_list => global%get_var_list_ptr () lval = eval_log (cmd%pn_lexpr, var_list) end subroutine cmd_record_execute @ %def cmd_record_execute @ \subsubsection{Unstable particles} Mark a particle as unstable. For each unstable particle, we store a number of decay channels and compute their respective BRs. <>= type, extends (command_t) :: cmd_unstable_t private integer :: n_proc = 0 type(string_t), dimension(:), allocatable :: process_id type(parse_node_t), pointer :: pn_prt_in => null () contains <> end type cmd_unstable_t @ %def cmd_unstable_t @ Output: we know the process IDs. <>= procedure :: write => cmd_unstable_write <>= subroutine cmd_unstable_write (cmd, unit, indent) class(cmd_unstable_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, i u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,1x,I0,1x,A)", advance="no") & "unstable:", 1, "(" do i = 1, cmd%n_proc if (i > 1) write (u, "(A,1x)", advance="no") "," write (u, "(A)", advance="no") char (cmd%process_id(i)) end do write (u, "(A)") ")" end subroutine cmd_unstable_write @ %def cmd_unstable_write @ Compile. Initiate an eval tree for the decaying particle and determine the decay channel process IDs. <>= procedure :: compile => cmd_unstable_compile <>= subroutine cmd_unstable_compile (cmd, global) class(cmd_unstable_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_list, pn_proc integer :: i cmd%pn_prt_in => parse_node_get_sub_ptr (cmd%pn, 2) pn_list => parse_node_get_next_ptr (cmd%pn_prt_in) if (associated (pn_list)) then select case (char (parse_node_get_rule_key (pn_list))) case ("unstable_arg") cmd%n_proc = parse_node_get_n_sub (pn_list) cmd%pn_opt => parse_node_get_next_ptr (pn_list) case default cmd%n_proc = 0 cmd%pn_opt => pn_list pn_list => null () end select end if call cmd%compile_options (global) if (associated (pn_list)) then allocate (cmd%process_id (cmd%n_proc)) pn_proc => parse_node_get_sub_ptr (pn_list) do i = 1, cmd%n_proc cmd%process_id(i) = parse_node_get_string (pn_proc) call cmd%local%process_stack%init_result_vars (cmd%process_id(i)) pn_proc => parse_node_get_next_ptr (pn_proc) end do else allocate (cmd%process_id (0)) end if end subroutine cmd_unstable_compile @ %def cmd_unstable_compile @ Command execution. Evaluate the decaying particle and mark the decays in the current model object. <>= procedure :: execute => cmd_unstable_execute <>= subroutine cmd_unstable_execute (cmd, global) class(cmd_unstable_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list logical :: auto_decays, auto_decays_radiative integer :: auto_decays_multiplicity logical :: isotropic_decay, diagonal_decay, polarized_decay integer :: decay_helicity type(pdg_array_t) :: pa_in integer :: pdg_in type(string_t) :: libname_cur, libname_dec type(string_t), dimension(:), allocatable :: auto_id, tmp_id integer :: n_proc_user integer :: i, u_tmp character(80) :: buffer var_list => cmd%local%get_var_list_ptr () auto_decays = & var_list%get_lval (var_str ("?auto_decays")) if (auto_decays) then auto_decays_multiplicity = & var_list%get_ival (var_str ("auto_decays_multiplicity")) auto_decays_radiative = & var_list%get_lval (var_str ("?auto_decays_radiative")) end if isotropic_decay = & var_list%get_lval (var_str ("?isotropic_decay")) if (isotropic_decay) then diagonal_decay = .false. polarized_decay = .false. else diagonal_decay = & var_list%get_lval (var_str ("?diagonal_decay")) if (diagonal_decay) then polarized_decay = .false. else polarized_decay = & var_list%is_known (var_str ("decay_helicity")) if (polarized_decay) then decay_helicity = var_list%get_ival (var_str ("decay_helicity")) end if end if end if pa_in = eval_pdg_array (cmd%pn_prt_in, var_list) if (pdg_array_get_length (pa_in) /= 1) & call msg_fatal ("Unstable: decaying particle must be unique") pdg_in = pdg_array_get (pa_in, 1) n_proc_user = cmd%n_proc if (auto_decays) then call create_auto_decays (pdg_in, & auto_decays_multiplicity, auto_decays_radiative, & libname_dec, auto_id, cmd%local) allocate (tmp_id (cmd%n_proc + size (auto_id))) tmp_id(:cmd%n_proc) = cmd%process_id tmp_id(cmd%n_proc+1:) = auto_id call move_alloc (from = tmp_id, to = cmd%process_id) cmd%n_proc = size (cmd%process_id) end if libname_cur = cmd%local%prclib%get_name () do i = 1, cmd%n_proc if (i == n_proc_user + 1) then call cmd%local%update_prclib & (cmd%local%prclib_stack%get_library_ptr (libname_dec)) end if if (.not. global%process_stack%exists (cmd%process_id(i))) then call var_list%set_log & (var_str ("?decay_rest_frame"), .false., is_known = .true.) call integrate_process (cmd%process_id(i), cmd%local, global) call global%process_stack%fill_result_vars (cmd%process_id(i)) end if end do call cmd%local%update_prclib & (cmd%local%prclib_stack%get_library_ptr (libname_cur)) if (cmd%n_proc > 0) then if (polarized_decay) then call global%modify_particle (pdg_in, stable = .false., & decay = cmd%process_id, & isotropic_decay = .false., & diagonal_decay = .false., & decay_helicity = decay_helicity, & polarized = .false.) else call global%modify_particle (pdg_in, stable = .false., & decay = cmd%process_id, & isotropic_decay = isotropic_decay, & diagonal_decay = diagonal_decay, & polarized = .false.) end if u_tmp = free_unit () open (u_tmp, status = "scratch", action = "readwrite") call show_unstable (global, pdg_in, u_tmp) rewind (u_tmp) do read (u_tmp, "(A)", end = 1) buffer write (msg_buffer, "(A)") trim (buffer) call msg_message () end do 1 continue close (u_tmp) else call err_unstable (global, pdg_in) end if end subroutine cmd_unstable_execute @ %def cmd_unstable_execute @ Show data for the current unstable particle. This is called both by the [[unstable]] and by the [[show]] command. To determine decay branching rations, we look at the decay process IDs and inspect the corresponding [[integral()]] result variables. <>= subroutine show_unstable (global, pdg, u) type(rt_data_t), intent(in), target :: global integer, intent(in) :: pdg, u type(flavor_t) :: flv type(string_t), dimension(:), allocatable :: decay real(default), dimension(:), allocatable :: br real(default) :: width type(process_t), pointer :: process type(process_component_def_t), pointer :: prc_def type(string_t), dimension(:), allocatable :: prt_out, prt_out_str integer :: i, j logical :: opened call flv%init (pdg, global%model) call flv%get_decays (decay) if (.not. allocated (decay)) return allocate (prt_out_str (size (decay))) allocate (br (size (decay))) do i = 1, size (br) process => global%process_stack%get_process_ptr (decay(i)) prc_def => process%get_component_def_ptr (1) call prc_def%get_prt_out (prt_out) prt_out_str(i) = prt_out(1) do j = 2, size (prt_out) prt_out_str(i) = prt_out_str(i) // ", " // prt_out(j) end do br(i) = global%get_rval ("integral(" // decay(i) // ")") end do if (all (br >= 0)) then if (any (br > 0)) then width = sum (br) br = br / sum (br) write (u, "(A)") "Unstable particle " & // char (flv%get_name ()) & // ": computed branching ratios:" do i = 1, size (br) write (u, "(2x,A,':'," // FMT_14 // ",3x,A)") & char (decay(i)), br(i), char (prt_out_str(i)) end do write (u, "(2x,'Total width ='," // FMT_14 // ",' GeV (computed)')") width write (u, "(2x,' ='," // FMT_14 // ",' GeV (preset)')") & flv%get_width () if (flv%decays_isotropically ()) then write (u, "(2x,A)") "Decay options: isotropic" else if (flv%decays_diagonal ()) then write (u, "(2x,A)") "Decay options: & &projection on diagonal helicity states" else if (flv%has_decay_helicity ()) then write (u, "(2x,A,1x,I0)") "Decay options: projection onto helicity =", & flv%get_decay_helicity () else write (u, "(2x,A)") "Decay options: helicity treated exactly" end if else inquire (unit = u, opened = opened) if (opened .and. .not. mask_fatal_errors) close (u) call msg_fatal ("Unstable particle " & // char (flv%get_name ()) & // ": partial width vanishes for all decay channels") end if else inquire (unit = u, opened = opened) if (opened .and. .not. mask_fatal_errors) close (u) call msg_fatal ("Unstable particle " & // char (flv%get_name ()) & // ": partial width is negative") end if end subroutine show_unstable @ %def show_unstable @ If no decays have been found, issue a non-fatal error. <>= subroutine err_unstable (global, pdg) type(rt_data_t), intent(in), target :: global integer, intent(in) :: pdg type(flavor_t) :: flv call flv%init (pdg, global%model) call msg_error ("Unstable: no allowed decays found for particle " & // char (flv%get_name ()) // ", keeping as stable") end subroutine err_unstable @ %def err_unstable @ Auto decays: create process IDs and make up process configurations, using the PDG codes generated by the [[ds_table]] make method. We allocate and use a self-contained process library that contains only the decay processes of the current particle. When done, we revert the global library pointer to the original library but return the name of the new one. The new library becomes part of the global library stack and can thus be referred to at any time. <>= subroutine create_auto_decays & (pdg_in, mult, rad, libname_dec, process_id, global) integer, intent(in) :: pdg_in integer, intent(in) :: mult logical, intent(in) :: rad type(string_t), intent(out) :: libname_dec type(string_t), dimension(:), allocatable, intent(out) :: process_id type(rt_data_t), intent(inout) :: global type(prclib_entry_t), pointer :: lib_entry type(process_library_t), pointer :: lib type(ds_table_t) :: ds_table type(split_constraints_t) :: constraints type(pdg_array_t), dimension(:), allocatable :: pa_out character(80) :: buffer character :: p_or_a type(string_t) :: process_string, libname_cur type(flavor_t) :: flv_in, flv_out type(string_t) :: prt_in type(string_t), dimension(:), allocatable :: prt_out type(process_configuration_t) :: prc_config integer :: i, j, k call flv_in%init (pdg_in, global%model) if (rad) then call constraints%init (2) else call constraints%init (3) call constraints%set (3, constrain_radiation ()) end if call constraints%set (1, constrain_n_tot (mult)) call constraints%set (2, & constrain_mass_sum (flv_in%get_mass (), margin = 0._default)) call ds_table%make (global%model, pdg_in, constraints) prt_in = flv_in%get_name () if (pdg_in > 0) then p_or_a = "p" else p_or_a = "a" end if if (ds_table%get_length () == 0) then call msg_warning ("Auto-decays: Particle " // char (prt_in) // ": " & // "no decays found") libname_dec = "" allocate (process_id (0)) else call msg_message ("Creating decay process library for particle " & // char (prt_in)) libname_cur = global%prclib%get_name () write (buffer, "(A,A,I0)") "_d", p_or_a, abs (pdg_in) libname_dec = libname_cur // trim (buffer) lib => global%prclib_stack%get_library_ptr (libname_dec) if (.not. (associated (lib))) then allocate (lib_entry) call lib_entry%init (libname_dec) lib => lib_entry%process_library_t call global%add_prclib (lib_entry) else call global%update_prclib (lib) end if allocate (process_id (ds_table%get_length ())) do i = 1, size (process_id) write (buffer, "(A,'_',A,I0,'_',I0)") & "decay", p_or_a, abs (pdg_in), i process_id(i) = trim (buffer) process_string = process_id(i) // ": " // prt_in // " =>" call ds_table%get_pdg_out (i, pa_out) allocate (prt_out (size (pa_out))) do j = 1, size (pa_out) do k = 1, pa_out(j)%get_length () call flv_out%init (pa_out(j)%get (k), global%model) if (k == 1) then prt_out(j) = flv_out%get_name () else prt_out(j) = prt_out(j) // ":" // flv_out%get_name () end if end do process_string = process_string // " " // prt_out(j) end do call msg_message (char (process_string)) call prc_config%init (process_id(i), 1, 1, & global%model, global%var_list, & nlo_process = global%nlo_fixed_order) !!! Causes runtime error with gfortran 4.9.1 ! call prc_config%setup_component (1, & ! new_prt_spec ([prt_in]), new_prt_spec (prt_out), global%model, global%var_list) !!! Workaround: call prc_config%setup_component (1, & [new_prt_spec (prt_in)], new_prt_spec (prt_out), global%model, global%var_list) call prc_config%record (global) deallocate (prt_out) deallocate (pa_out) end do lib => global%prclib_stack%get_library_ptr (libname_cur) call global%update_prclib (lib) end if call ds_table%final () end subroutine create_auto_decays @ %def create_auto_decays @ \subsubsection{(Stable particles} Revert the unstable declaration for a list of particles. <>= type, extends (command_t) :: cmd_stable_t private type(parse_node_p), dimension(:), allocatable :: pn_pdg contains <> end type cmd_stable_t @ %def cmd_stable_t @ Output: we know only the number of particles. <>= procedure :: write => cmd_stable_write <>= subroutine cmd_stable_write (cmd, unit, indent) class(cmd_stable_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,1x,I0)") "stable:", size (cmd%pn_pdg) end subroutine cmd_stable_write @ %def cmd_stable_write @ Compile. Assign parse nodes for the particle IDs. <>= procedure :: compile => cmd_stable_compile <>= subroutine cmd_stable_compile (cmd, global) class(cmd_stable_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_list, pn_prt integer :: n, i pn_list => parse_node_get_sub_ptr (cmd%pn, 2) cmd%pn_opt => parse_node_get_next_ptr (pn_list) call cmd%compile_options (global) n = parse_node_get_n_sub (pn_list) allocate (cmd%pn_pdg (n)) pn_prt => parse_node_get_sub_ptr (pn_list) i = 1 do while (associated (pn_prt)) cmd%pn_pdg(i)%ptr => pn_prt pn_prt => parse_node_get_next_ptr (pn_prt) i = i + 1 end do end subroutine cmd_stable_compile @ %def cmd_stable_compile @ Execute: apply the modifications to the current model. <>= procedure :: execute => cmd_stable_execute <>= subroutine cmd_stable_execute (cmd, global) class(cmd_stable_t), intent(inout) :: cmd type(rt_data_t), target, intent(inout) :: global type(var_list_t), pointer :: var_list type(pdg_array_t) :: pa integer :: pdg type(flavor_t) :: flv integer :: i var_list => cmd%local%get_var_list_ptr () do i = 1, size (cmd%pn_pdg) pa = eval_pdg_array (cmd%pn_pdg(i)%ptr, var_list) if (pdg_array_get_length (pa) /= 1) & call msg_fatal ("Stable: listed particles must be unique") pdg = pdg_array_get (pa, 1) call global%modify_particle (pdg, stable = .true., & isotropic_decay = .false., & diagonal_decay = .false., & polarized = .false.) call flv%init (pdg, cmd%local%model) call msg_message ("Particle " & // char (flv%get_name ()) & // " declared as stable") end do end subroutine cmd_stable_execute @ %def cmd_stable_execute @ \subsubsection{Polarized particles} These commands mark particles as (un)polarized, to be applied in subsequent simulation passes. Since this is technically the same as the [[stable]] command, we take a shortcut and make this an extension, just overriding methods. <>= type, extends (cmd_stable_t) :: cmd_polarized_t contains <> end type cmd_polarized_t type, extends (cmd_stable_t) :: cmd_unpolarized_t contains <> end type cmd_unpolarized_t @ %def cmd_polarized_t cmd_unpolarized_t @ Output: we know only the number of particles. <>= procedure :: write => cmd_polarized_write <>= procedure :: write => cmd_unpolarized_write <>= subroutine cmd_polarized_write (cmd, unit, indent) class(cmd_polarized_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,1x,I0)") "polarized:", size (cmd%pn_pdg) end subroutine cmd_polarized_write subroutine cmd_unpolarized_write (cmd, unit, indent) class(cmd_unpolarized_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,1x,I0)") "unpolarized:", size (cmd%pn_pdg) end subroutine cmd_unpolarized_write @ %def cmd_polarized_write @ %def cmd_unpolarized_write @ Compile: accounted for by the base command. Execute: apply the modifications to the current model. <>= procedure :: execute => cmd_polarized_execute <>= procedure :: execute => cmd_unpolarized_execute <>= subroutine cmd_polarized_execute (cmd, global) class(cmd_polarized_t), intent(inout) :: cmd type(rt_data_t), target, intent(inout) :: global type(var_list_t), pointer :: var_list type(pdg_array_t) :: pa integer :: pdg type(flavor_t) :: flv integer :: i var_list => cmd%local%get_var_list_ptr () do i = 1, size (cmd%pn_pdg) pa = eval_pdg_array (cmd%pn_pdg(i)%ptr, var_list) if (pdg_array_get_length (pa) /= 1) & call msg_fatal ("Polarized: listed particles must be unique") pdg = pdg_array_get (pa, 1) call global%modify_particle (pdg, polarized = .true., & stable = .true., & isotropic_decay = .false., & diagonal_decay = .false.) call flv%init (pdg, cmd%local%model) call msg_message ("Particle " & // char (flv%get_name ()) & // " declared as polarized") end do end subroutine cmd_polarized_execute subroutine cmd_unpolarized_execute (cmd, global) class(cmd_unpolarized_t), intent(inout) :: cmd type(rt_data_t), target, intent(inout) :: global type(var_list_t), pointer :: var_list type(pdg_array_t) :: pa integer :: pdg type(flavor_t) :: flv integer :: i var_list => cmd%local%get_var_list_ptr () do i = 1, size (cmd%pn_pdg) pa = eval_pdg_array (cmd%pn_pdg(i)%ptr, var_list) if (pdg_array_get_length (pa) /= 1) & call msg_fatal ("Unpolarized: listed particles must be unique") pdg = pdg_array_get (pa, 1) call global%modify_particle (pdg, polarized = .false., & stable = .true., & isotropic_decay = .false., & diagonal_decay = .false.) call flv%init (pdg, cmd%local%model) call msg_message ("Particle " & // char (flv%get_name ()) & // " declared as unpolarized") end do end subroutine cmd_unpolarized_execute @ %def cmd_polarized_execute @ %def cmd_unpolarized_execute @ \subsubsection{Parameters: formats for event-sample output} Specify all event formats that are to be used for output files in the subsequent simulation run. (The raw format is on by default and can be turned off here.) <>= type, extends (command_t) :: cmd_sample_format_t private type(string_t), dimension(:), allocatable :: format contains <> end type cmd_sample_format_t @ %def cmd_sample_format_t @ Output: here, everything is known. <>= procedure :: write => cmd_sample_format_write <>= subroutine cmd_sample_format_write (cmd, unit, indent) class(cmd_sample_format_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, i u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)", advance="no") "sample_format = " do i = 1, size (cmd%format) if (i > 1) write (u, "(A,1x)", advance="no") "," write (u, "(A)", advance="no") char (cmd%format(i)) end do write (u, "(A)") end subroutine cmd_sample_format_write @ %def cmd_sample_format_write @ Compile. Initialize evaluation trees. <>= procedure :: compile => cmd_sample_format_compile <>= subroutine cmd_sample_format_compile (cmd, global) class(cmd_sample_format_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_arg type(parse_node_t), pointer :: pn_format integer :: i, n_format pn_arg => parse_node_get_sub_ptr (cmd%pn, 3) if (associated (pn_arg)) then n_format = parse_node_get_n_sub (pn_arg) allocate (cmd%format (n_format)) pn_format => parse_node_get_sub_ptr (pn_arg) i = 0 do while (associated (pn_format)) i = i + 1 cmd%format(i) = parse_node_get_string (pn_format) pn_format => parse_node_get_next_ptr (pn_format) end do else allocate (cmd%format (0)) end if end subroutine cmd_sample_format_compile @ %def cmd_sample_format_compile @ Execute. Transfer the list of format specifications to the corresponding array in the runtime data set. <>= procedure :: execute => cmd_sample_format_execute <>= subroutine cmd_sample_format_execute (cmd, global) class(cmd_sample_format_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global if (allocated (global%sample_fmt)) deallocate (global%sample_fmt) allocate (global%sample_fmt (size (cmd%format)), source = cmd%format) end subroutine cmd_sample_format_execute @ %def cmd_sample_format_execute @ \subsubsection{The simulate command} This is the actual SINDARIN command. <>= type, extends (command_t) :: cmd_simulate_t ! not private anymore as required by the whizard-c-interface integer :: n_proc = 0 type(string_t), dimension(:), allocatable :: process_id contains <> end type cmd_simulate_t @ %def cmd_simulate_t @ Output: we know the process IDs. <>= procedure :: write => cmd_simulate_write <>= subroutine cmd_simulate_write (cmd, unit, indent) class(cmd_simulate_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, i u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)", advance="no") "simulate (" do i = 1, cmd%n_proc if (i > 1) write (u, "(A,1x)", advance="no") "," write (u, "(A)", advance="no") char (cmd%process_id(i)) end do write (u, "(A)") ")" end subroutine cmd_simulate_write @ %def cmd_simulate_write @ Compile. In contrast to WHIZARD 1 the confusing option to give the number of unweighted events for weighted events as if unweighting were to take place has been abandoned. (We both use [[n_events]] for weighted and unweighted events, the variable [[n_calls]] from WHIZARD 1 has been discarded. <>= procedure :: compile => cmd_simulate_compile <>= subroutine cmd_simulate_compile (cmd, global) class(cmd_simulate_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_proclist, pn_proc integer :: i pn_proclist => parse_node_get_sub_ptr (cmd%pn, 2) cmd%pn_opt => parse_node_get_next_ptr (pn_proclist) call cmd%compile_options (global) cmd%n_proc = parse_node_get_n_sub (pn_proclist) allocate (cmd%process_id (cmd%n_proc)) pn_proc => parse_node_get_sub_ptr (pn_proclist) do i = 1, cmd%n_proc cmd%process_id(i) = parse_node_get_string (pn_proc) call global%process_stack%init_result_vars (cmd%process_id(i)) pn_proc => parse_node_get_next_ptr (pn_proc) end do end subroutine cmd_simulate_compile @ %def cmd_simulate_compile @ Execute command: Simulate events. This is done via a [[simulation_t]] object and its associated methods. Signal handling: the [[generate]] method may exit abnormally if there is a pending signal. The current logic ensures that the [[es_array]] output channels are closed before the [[execute]] routine returns. The program will terminate then in [[command_list_execute]]. <>= procedure :: execute => cmd_simulate_execute <>= subroutine cmd_simulate_execute (cmd, global) class(cmd_simulate_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(rt_data_t), dimension(:), allocatable, target :: alt_env integer :: n_events, n_fmt type(string_t) :: sample, sample_suffix logical :: rebuild_events, read_raw, write_raw type(simulation_t), target :: sim type(string_t), dimension(:), allocatable :: sample_fmt type(event_stream_array_t) :: es_array type(event_sample_data_t) :: data integer :: i, checkpoint, callback <> var_list => cmd%local%var_list if (allocated (cmd%local%pn%alt_setup)) then allocate (alt_env (size (cmd%local%pn%alt_setup))) do i = 1, size (alt_env) call build_alt_setup (alt_env(i), cmd%local, & cmd%local%pn%alt_setup(i)%ptr) end do call sim%init (cmd%process_id, .true., .true., cmd%local, global, & alt_env) else call sim%init (cmd%process_id, .true., .true., cmd%local, global) end if if (signal_is_pending ()) return if (sim%is_valid ()) then call sim%init_process_selector () call openmp_set_num_threads_verbose & (var_list%get_ival (var_str ("openmp_num_threads")), & var_list%get_lval (var_str ("?openmp_logging"))) call sim%compute_n_events (n_events, var_list) sample_suffix = "" <> sample = var_list%get_sval (var_str ("$sample")) if (sample == "") then sample = sim%get_default_sample_name () // sample_suffix else sample = var_list%get_sval (var_str ("$sample")) // sample_suffix end if rebuild_events = & var_list%get_lval (var_str ("?rebuild_events")) read_raw = & var_list%get_lval (var_str ("?read_raw")) & .and. .not. rebuild_events write_raw = & var_list%get_lval (var_str ("?write_raw")) checkpoint = & var_list%get_ival (var_str ("checkpoint")) callback = & var_list%get_ival (var_str ("event_callback_interval")) if (read_raw) then inquire (file = char (sample) // ".evx", exist = read_raw) end if if (allocated (cmd%local%sample_fmt)) then n_fmt = size (cmd%local%sample_fmt) else n_fmt = 0 end if data = sim%get_data () data%n_evt = n_events data%nlo_multiplier = sim%get_n_nlo_entries (1) if (read_raw) then allocate (sample_fmt (n_fmt)) if (n_fmt > 0) sample_fmt = cmd%local%sample_fmt call es_array%init (sample, & sample_fmt, cmd%local, & data = data, & input = var_str ("raw"), & allow_switch = write_raw, & checkpoint = checkpoint, & callback = callback) call sim%generate (n_events, es_array) call es_array%final () else if (write_raw) then allocate (sample_fmt (n_fmt + 1)) if (n_fmt > 0) sample_fmt(:n_fmt) = cmd%local%sample_fmt sample_fmt(n_fmt+1) = var_str ("raw") call es_array%init (sample, & sample_fmt, cmd%local, & data = data, & checkpoint = checkpoint, & callback = callback) call sim%generate (n_events, es_array) call es_array%final () else if (allocated (cmd%local%sample_fmt) & .or. checkpoint > 0 & .or. callback > 0) then allocate (sample_fmt (n_fmt)) if (n_fmt > 0) sample_fmt = cmd%local%sample_fmt call es_array%init (sample, & sample_fmt, cmd%local, & data = data, & checkpoint = checkpoint, & callback = callback) call sim%generate (n_events, es_array) call es_array%final () else call sim%generate (n_events) end if if (allocated (alt_env)) then do i = 1, size (alt_env) call alt_env(i)%local_final () end do end if end if call sim%final () end subroutine cmd_simulate_execute @ %def cmd_simulate_execute <>= @ <>= @ <>= logical :: mpi_logging integer :: rank, n_size @ Append rank id to sample name. <>= call mpi_get_comm_id (n_size, rank) if (n_size > 1) then sample_suffix = var_str ("_") // str (rank) end if mpi_logging = (("vamp2" == char (var_list%get_sval (var_str ("$integration_method"))) & & .and. (n_size > 1)) & & .or. var_list%get_lval (var_str ("?mpi_logging"))) call mpi_set_logging (mpi_logging) @ @ Build an alternative setup: the parse tree is stored in the global environment. We create a temporary command list to compile and execute this; the result is an alternative local environment [[alt_env]] which we can hand over to the [[simulate]] command. <>= recursive subroutine build_alt_setup (alt_env, global, pn) type(rt_data_t), intent(inout), target :: alt_env type(rt_data_t), intent(inout), target :: global type(parse_node_t), intent(in), target :: pn type(command_list_t), allocatable :: alt_options allocate (alt_options) call alt_env%local_init (global) call alt_env%activate () call alt_options%compile (pn, alt_env) call alt_options%execute (alt_env) call alt_env%deactivate (global, keep_local = .true.) call alt_options%final () end subroutine build_alt_setup @ %def build_alt_setup @ \subsubsection{The rescan command} This is the actual SINDARIN command. <>= type, extends (command_t) :: cmd_rescan_t ! private type(parse_node_t), pointer :: pn_filename => null () integer :: n_proc = 0 type(string_t), dimension(:), allocatable :: process_id contains <> end type cmd_rescan_t @ %def cmd_rescan_t @ Output: we know the process IDs. <>= procedure :: write => cmd_rescan_write <>= subroutine cmd_rescan_write (cmd, unit, indent) class(cmd_rescan_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, i u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)", advance="no") "rescan (" do i = 1, cmd%n_proc if (i > 1) write (u, "(A,1x)", advance="no") "," write (u, "(A)", advance="no") char (cmd%process_id(i)) end do write (u, "(A)") ")" end subroutine cmd_rescan_write @ %def cmd_rescan_write @ Compile. The command takes a suffix argument, namely the file name of requested event file. <>= procedure :: compile => cmd_rescan_compile <>= subroutine cmd_rescan_compile (cmd, global) class(cmd_rescan_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_filename, pn_proclist, pn_proc integer :: i pn_filename => parse_node_get_sub_ptr (cmd%pn, 2) pn_proclist => parse_node_get_next_ptr (pn_filename) cmd%pn_opt => parse_node_get_next_ptr (pn_proclist) call cmd%compile_options (global) cmd%pn_filename => pn_filename cmd%n_proc = parse_node_get_n_sub (pn_proclist) allocate (cmd%process_id (cmd%n_proc)) pn_proc => parse_node_get_sub_ptr (pn_proclist) do i = 1, cmd%n_proc cmd%process_id(i) = parse_node_get_string (pn_proc) pn_proc => parse_node_get_next_ptr (pn_proc) end do end subroutine cmd_rescan_compile @ %def cmd_rescan_compile @ Execute command: Rescan events. This is done via a [[simulation_t]] object and its associated methods. <>= procedure :: execute => cmd_rescan_execute <>= subroutine cmd_rescan_execute (cmd, global) class(cmd_rescan_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(rt_data_t), dimension(:), allocatable, target :: alt_env type(string_t) :: sample, sample_suffix logical :: exist, write_raw, update_event, update_sqme type(simulation_t), target :: sim type(event_sample_data_t) :: input_data, data type(string_t) :: input_sample integer :: n_fmt type(string_t), dimension(:), allocatable :: sample_fmt type(string_t) :: input_format, input_ext, input_file type(string_t) :: lhef_extension, extension_hepmc, extension_lcio type(event_stream_array_t) :: es_array integer :: i, n_events <> var_list => cmd%local%var_list if (allocated (cmd%local%pn%alt_setup)) then allocate (alt_env (size (cmd%local%pn%alt_setup))) do i = 1, size (alt_env) call build_alt_setup (alt_env(i), cmd%local, & cmd%local%pn%alt_setup(i)%ptr) end do call sim%init (cmd%process_id, .false., .false., cmd%local, global, & alt_env) else call sim%init (cmd%process_id, .false., .false., cmd%local, global) end if call sim%compute_n_events (n_events, var_list) input_sample = eval_string (cmd%pn_filename, var_list) input_format = var_list%get_sval (& var_str ("$rescan_input_format")) sample_suffix = "" <> sample = var_list%get_sval (var_str ("$sample")) if (sample == "") then sample = sim%get_default_sample_name () // sample_suffix else sample = var_list%get_sval (var_str ("$sample")) // sample_suffix end if write_raw = var_list%get_lval (var_str ("?write_raw")) if (allocated (cmd%local%sample_fmt)) then n_fmt = size (cmd%local%sample_fmt) else n_fmt = 0 end if if (write_raw) then if (sample == input_sample) then call msg_error ("Rescan: ?write_raw = true: " & // "suppressing raw event output (filename clashes with input)") allocate (sample_fmt (n_fmt)) if (n_fmt > 0) sample_fmt = cmd%local%sample_fmt else allocate (sample_fmt (n_fmt + 1)) if (n_fmt > 0) sample_fmt(:n_fmt) = cmd%local%sample_fmt sample_fmt(n_fmt+1) = var_str ("raw") end if else allocate (sample_fmt (n_fmt)) if (n_fmt > 0) sample_fmt = cmd%local%sample_fmt end if update_event = & var_list%get_lval (var_str ("?update_event")) update_sqme = & var_list%get_lval (var_str ("?update_sqme")) if (update_event .or. update_sqme) then call msg_message ("Recalculating observables") if (update_sqme) then call msg_message ("Recalculating squared matrix elements") end if end if lhef_extension = & var_list%get_sval (var_str ("$lhef_extension")) extension_hepmc = & var_list%get_sval (var_str ("$extension_hepmc")) extension_lcio = & var_list%get_sval (var_str ("$extension_lcio")) select case (char (input_format)) case ("raw"); input_ext = "evx" call cmd%local%set_log & (var_str ("?recover_beams"), .false., is_known=.true.) case ("lhef"); input_ext = lhef_extension case ("hepmc"); input_ext = extension_hepmc case default call msg_fatal ("rescan: input sample format '" // char (input_format) & // "' not supported") end select input_file = input_sample // "." // input_ext inquire (file = char (input_file), exist = exist) if (exist) then input_data = sim%get_data (alt = .false.) input_data%n_evt = n_events data = sim%get_data () data%n_evt = n_events input_data%md5sum_cfg = "" call es_array%init (sample, & sample_fmt, cmd%local, data, & input = input_format, input_sample = input_sample, & input_data = input_data, & allow_switch = .false.) call sim%rescan (n_events, es_array, global = cmd%local) call es_array%final () else call msg_fatal ("Rescan: event file '" & // char (input_file) // "' not found") end if if (allocated (alt_env)) then do i = 1, size (alt_env) call alt_env(i)%local_final () end do end if call sim%final () end subroutine cmd_rescan_execute @ %def cmd_rescan_execute @ <>= @ <>= @ <>= logical :: mpi_logging integer :: rank, n_size @ Append rank id to sample name. <>= call mpi_get_comm_id (n_size, rank) if (n_size > 1) then sample_suffix = var_str ("_") // str (rank) end if mpi_logging = (("vamp2" == char (var_list%get_sval (var_str ("$integration_method"))) & & .and. (n_size > 1)) & & .or. var_list%get_lval (var_str ("?mpi_logging"))) call mpi_set_logging (mpi_logging) @ \subsubsection{Parameters: number of iterations} Specify number of iterations and number of calls for one integration pass. <>= type, extends (command_t) :: cmd_iterations_t private integer :: n_pass = 0 type(parse_node_p), dimension(:), allocatable :: pn_expr_n_it type(parse_node_p), dimension(:), allocatable :: pn_expr_n_calls type(parse_node_p), dimension(:), allocatable :: pn_sexpr_adapt contains <> end type cmd_iterations_t @ %def cmd_iterations_t @ Output. Display the number of passes, which is known after compilation. <>= procedure :: write => cmd_iterations_write <>= subroutine cmd_iterations_write (cmd, unit, indent) class(cmd_iterations_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) select case (cmd%n_pass) case (0) write (u, "(1x,A)") "iterations: [empty]" case (1) write (u, "(1x,A,I0,A)") "iterations: ", cmd%n_pass, " pass" case default write (u, "(1x,A,I0,A)") "iterations: ", cmd%n_pass, " passes" end select end subroutine cmd_iterations_write @ %def cmd_iterations_write @ Compile. Initialize evaluation trees. <>= procedure :: compile => cmd_iterations_compile <>= subroutine cmd_iterations_compile (cmd, global) class(cmd_iterations_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_arg, pn_n_it, pn_n_calls, pn_adapt type(parse_node_t), pointer :: pn_it_spec, pn_calls_spec, pn_adapt_spec integer :: i pn_arg => parse_node_get_sub_ptr (cmd%pn, 3) if (associated (pn_arg)) then cmd%n_pass = parse_node_get_n_sub (pn_arg) allocate (cmd%pn_expr_n_it (cmd%n_pass)) allocate (cmd%pn_expr_n_calls (cmd%n_pass)) allocate (cmd%pn_sexpr_adapt (cmd%n_pass)) pn_it_spec => parse_node_get_sub_ptr (pn_arg) i = 1 do while (associated (pn_it_spec)) pn_n_it => parse_node_get_sub_ptr (pn_it_spec) pn_calls_spec => parse_node_get_next_ptr (pn_n_it) pn_n_calls => parse_node_get_sub_ptr (pn_calls_spec, 2) pn_adapt_spec => parse_node_get_next_ptr (pn_calls_spec) if (associated (pn_adapt_spec)) then pn_adapt => parse_node_get_sub_ptr (pn_adapt_spec, 2) else pn_adapt => null () end if cmd%pn_expr_n_it(i)%ptr => pn_n_it cmd%pn_expr_n_calls(i)%ptr => pn_n_calls cmd%pn_sexpr_adapt(i)%ptr => pn_adapt i = i + 1 pn_it_spec => parse_node_get_next_ptr (pn_it_spec) end do else allocate (cmd%pn_expr_n_it (0)) allocate (cmd%pn_expr_n_calls (0)) end if end subroutine cmd_iterations_compile @ %def cmd_iterations_compile @ Execute. Evaluate the trees and transfer the results to the iteration list in the runtime data set. <>= procedure :: execute => cmd_iterations_execute <>= subroutine cmd_iterations_execute (cmd, global) class(cmd_iterations_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list integer, dimension(cmd%n_pass) :: n_it, n_calls logical, dimension(cmd%n_pass) :: custom_adapt type(string_t), dimension(cmd%n_pass) :: adapt_code integer :: i var_list => global%get_var_list_ptr () do i = 1, cmd%n_pass n_it(i) = eval_int (cmd%pn_expr_n_it(i)%ptr, var_list) n_calls(i) = & eval_int (cmd%pn_expr_n_calls(i)%ptr, var_list) if (associated (cmd%pn_sexpr_adapt(i)%ptr)) then adapt_code(i) = & eval_string (cmd%pn_sexpr_adapt(i)%ptr, & var_list, is_known = custom_adapt(i)) else custom_adapt(i) = .false. end if end do call global%it_list%init (n_it, n_calls, custom_adapt, adapt_code) end subroutine cmd_iterations_execute @ %def cmd_iterations_execute @ \subsubsection{Range expressions} We need a special type for storing and evaluating range expressions. <>= integer, parameter :: STEP_NONE = 0 integer, parameter :: STEP_ADD = 1 integer, parameter :: STEP_SUB = 2 integer, parameter :: STEP_MUL = 3 integer, parameter :: STEP_DIV = 4 integer, parameter :: STEP_COMP_ADD = 11 integer, parameter :: STEP_COMP_MUL = 13 @ There is an abstract base type and two implementations: scan over integers and scan over reals. <>= type, abstract :: range_t type(parse_node_t), pointer :: pn_expr => null () type(parse_node_t), pointer :: pn_term => null () type(parse_node_t), pointer :: pn_factor => null () type(parse_node_t), pointer :: pn_value => null () type(parse_node_t), pointer :: pn_literal => null () type(parse_node_t), pointer :: pn_beg => null () type(parse_node_t), pointer :: pn_end => null () type(parse_node_t), pointer :: pn_step => null () type(eval_tree_t) :: expr_beg type(eval_tree_t) :: expr_end type(eval_tree_t) :: expr_step integer :: step_mode = 0 integer :: n_step = 0 contains <> end type range_t @ %def range_t @ These are the implementations: <>= type, extends (range_t) :: range_int_t integer :: i_beg = 0 integer :: i_end = 0 integer :: i_step = 0 contains <> end type range_int_t type, extends (range_t) :: range_real_t real(default) :: r_beg = 0 real(default) :: r_end = 0 real(default) :: r_step = 0 real(default) :: lr_beg = 0 real(default) :: lr_end = 0 real(default) :: lr_step = 0 contains <> end type range_real_t @ %def range_int_t range_real_t @ Finalize the allocated dummy node. The other nodes are just pointers. <>= procedure :: final => range_final <>= subroutine range_final (object) class(range_t), intent(inout) :: object if (associated (object%pn_expr)) then call parse_node_final (object%pn_expr, recursive = .false.) call parse_node_final (object%pn_term, recursive = .false.) call parse_node_final (object%pn_factor, recursive = .false.) call parse_node_final (object%pn_value, recursive = .false.) call parse_node_final (object%pn_literal, recursive = .false.) deallocate (object%pn_expr) deallocate (object%pn_term) deallocate (object%pn_factor) deallocate (object%pn_value) deallocate (object%pn_literal) end if end subroutine range_final @ %def range_final @ Output. <>= procedure (range_write), deferred :: write procedure :: base_write => range_write <>= procedure :: write => range_int_write <>= procedure :: write => range_real_write <>= subroutine range_write (object, unit) class(range_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Range specification:" if (associated (object%pn_expr)) then write (u, "(1x,A)") "Dummy value:" call parse_node_write_rec (object%pn_expr, u) end if if (associated (object%pn_beg)) then write (u, "(1x,A)") "Initial value:" call parse_node_write_rec (object%pn_beg, u) call object%expr_beg%write (u) if (associated (object%pn_end)) then write (u, "(1x,A)") "Final value:" call parse_node_write_rec (object%pn_end, u) call object%expr_end%write (u) if (associated (object%pn_step)) then write (u, "(1x,A)") "Step value:" call parse_node_write_rec (object%pn_step, u) select case (object%step_mode) case (STEP_ADD); write (u, "(1x,A)") "Step mode: +" case (STEP_SUB); write (u, "(1x,A)") "Step mode: -" case (STEP_MUL); write (u, "(1x,A)") "Step mode: *" case (STEP_DIV); write (u, "(1x,A)") "Step mode: /" case (STEP_COMP_ADD); write (u, "(1x,A)") "Division mode: +" case (STEP_COMP_MUL); write (u, "(1x,A)") "Division mode: *" end select end if end if else write (u, "(1x,A)") "Expressions: [undefined]" end if end subroutine range_write subroutine range_int_write (object, unit) class(range_int_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) call object%base_write (unit) write (u, "(1x,A)") "Range parameters:" write (u, "(3x,A,I0)") "i_beg = ", object%i_beg write (u, "(3x,A,I0)") "i_end = ", object%i_end write (u, "(3x,A,I0)") "i_step = ", object%i_step write (u, "(3x,A,I0)") "n_step = ", object%n_step end subroutine range_int_write subroutine range_real_write (object, unit) class(range_real_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) call object%base_write (unit) write (u, "(1x,A)") "Range parameters:" write (u, "(3x,A," // FMT_19 // ")") "r_beg = ", object%r_beg write (u, "(3x,A," // FMT_19 // ")") "r_end = ", object%r_end write (u, "(3x,A," // FMT_19 // ")") "r_step = ", object%r_end write (u, "(3x,A,I0)") "n_step = ", object%n_step end subroutine range_real_write @ %def range_write @ Initialize, given a range expression parse node. This is common to the implementations. <>= procedure :: init => range_init <>= subroutine range_init (range, pn) class(range_t), intent(out) :: range type(parse_node_t), intent(in), target :: pn type(parse_node_t), pointer :: pn_spec, pn_end, pn_step_spec, pn_op select case (char (parse_node_get_rule_key (pn))) case ("expr") case ("range_expr") range%pn_beg => parse_node_get_sub_ptr (pn) pn_spec => parse_node_get_next_ptr (range%pn_beg) if (associated (pn_spec)) then pn_end => parse_node_get_sub_ptr (pn_spec, 2) range%pn_end => pn_end pn_step_spec => parse_node_get_next_ptr (pn_end) if (associated (pn_step_spec)) then pn_op => parse_node_get_sub_ptr (pn_step_spec) range%pn_step => parse_node_get_next_ptr (pn_op) select case (char (parse_node_get_rule_key (pn_op))) case ("/+"); range%step_mode = STEP_ADD case ("/-"); range%step_mode = STEP_SUB case ("/*"); range%step_mode = STEP_MUL case ("//"); range%step_mode = STEP_DIV case ("/+/"); range%step_mode = STEP_COMP_ADD case ("/*/"); range%step_mode = STEP_COMP_MUL case default call range%write () call msg_bug ("Range: step mode not implemented") end select else range%step_mode = STEP_ADD end if else range%step_mode = STEP_NONE end if call range%create_value_node () case default call msg_bug ("range expression: node type '" & // char (parse_node_get_rule_key (pn)) & // "' not implemented") end select end subroutine range_init @ %def range_init @ This method manually creates a parse node (actually, a cascade of parse nodes) that hold a constant value as a literal. The idea is that this node is inserted as the right-hand side of a fake variable assignment, which is prepended to each scan iteration. Before the variable assignment is compiled and executed, we can manually reset the value of the literal and thus pretend that the loop variable is assigned this value. <>= procedure :: create_value_node => range_create_value_node <>= subroutine range_create_value_node (range) class(range_t), intent(inout) :: range allocate (range%pn_literal) allocate (range%pn_value) select type (range) type is (range_int_t) call parse_node_create_value (range%pn_literal, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("integer_literal")),& ival = 0) call parse_node_create_branch (range%pn_value, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("integer_value"))) type is (range_real_t) call parse_node_create_value (range%pn_literal, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("real_literal")),& rval = 0._default) call parse_node_create_branch (range%pn_value, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("real_value"))) class default call msg_bug ("range: create value node: type not implemented") end select call parse_node_append_sub (range%pn_value, range%pn_literal) call parse_node_freeze_branch (range%pn_value) allocate (range%pn_factor) call parse_node_create_branch (range%pn_factor, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("factor"))) call parse_node_append_sub (range%pn_factor, range%pn_value) call parse_node_freeze_branch (range%pn_factor) allocate (range%pn_term) call parse_node_create_branch (range%pn_term, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("term"))) call parse_node_append_sub (range%pn_term, range%pn_factor) call parse_node_freeze_branch (range%pn_term) allocate (range%pn_expr) call parse_node_create_branch (range%pn_expr, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("expr"))) call parse_node_append_sub (range%pn_expr, range%pn_term) call parse_node_freeze_branch (range%pn_expr) end subroutine range_create_value_node @ %def range_create_value_node @ Compile, given an environment. <>= procedure :: compile => range_compile <>= subroutine range_compile (range, global) class(range_t), intent(inout) :: range type(rt_data_t), intent(in), target :: global type(var_list_t), pointer :: var_list var_list => global%get_var_list_ptr () if (associated (range%pn_beg)) then call range%expr_beg%init_expr (range%pn_beg, var_list) if (associated (range%pn_end)) then call range%expr_end%init_expr (range%pn_end, var_list) if (associated (range%pn_step)) then call range%expr_step%init_expr (range%pn_step, var_list) end if end if end if end subroutine range_compile @ %def range_compile @ Evaluate: compute the actual bounds and parameters that determine the values that we can iterate. This is implementation-specific. <>= procedure (range_evaluate), deferred :: evaluate <>= abstract interface subroutine range_evaluate (range) import class(range_t), intent(inout) :: range end subroutine range_evaluate end interface @ %def range_evaluate @ The version for an integer variable. If the step is subtractive, we invert the sign and treat it as an additive step. For a multiplicative step, the step must be greater than one, and the initial and final values must be of same sign and strictly ordered. Analogously for a division step. <>= procedure :: evaluate => range_int_evaluate <>= subroutine range_int_evaluate (range) class(range_int_t), intent(inout) :: range integer :: ival if (associated (range%pn_beg)) then call range%expr_beg%evaluate () if (range%expr_beg%is_known ()) then range%i_beg = range%expr_beg%get_int () else call range%write () call msg_fatal & ("Range expression: initial value evaluates to unknown") end if if (associated (range%pn_end)) then call range%expr_end%evaluate () if (range%expr_end%is_known ()) then range%i_end = range%expr_end%get_int () if (associated (range%pn_step)) then call range%expr_step%evaluate () if (range%expr_step%is_known ()) then range%i_step = range%expr_step%get_int () select case (range%step_mode) case (STEP_SUB); range%i_step = - range%i_step end select else call range%write () call msg_fatal & ("Range expression: step value evaluates to unknown") end if else range%i_step = 1 end if else call range%write () call msg_fatal & ("Range expression: final value evaluates to unknown") end if else range%i_end = range%i_beg range%i_step = 1 end if select case (range%step_mode) case (STEP_NONE) range%n_step = 1 case (STEP_ADD, STEP_SUB) if (range%i_step /= 0) then if (range%i_beg == range%i_end) then range%n_step = 1 else if (sign (1, range%i_end - range%i_beg) & == sign (1, range%i_step)) then range%n_step = (range%i_end - range%i_beg) / range%i_step + 1 else range%n_step = 0 end if else call msg_fatal ("range evaluation (add): step value is zero") end if case (STEP_MUL) if (range%i_step > 1) then if (range%i_beg == range%i_end) then range%n_step = 1 else if (range%i_beg == 0) then call msg_fatal ("range evaluation (mul): initial value is zero") else if (sign (1, range%i_beg) == sign (1, range%i_end) & .and. abs (range%i_beg) < abs (range%i_end)) then range%n_step = 0 ival = range%i_beg do while (abs (ival) <= abs (range%i_end)) range%n_step = range%n_step + 1 ival = ival * range%i_step end do else range%n_step = 0 end if else call msg_fatal & ("range evaluation (mult): step value is one or less") end if case (STEP_DIV) if (range%i_step > 1) then if (range%i_beg == range%i_end) then range%n_step = 1 else if (sign (1, range%i_beg) == sign (1, range%i_end) & .and. abs (range%i_beg) > abs (range%i_end)) then range%n_step = 0 ival = range%i_beg do while (abs (ival) >= abs (range%i_end)) range%n_step = range%n_step + 1 if (ival == 0) exit ival = ival / range%i_step end do else range%n_step = 0 end if else call msg_fatal & ("range evaluation (div): step value is one or less") end if case (STEP_COMP_ADD) call msg_fatal ("range evaluation: & &step mode /+/ not allowed for integer variable") case (STEP_COMP_MUL) call msg_fatal ("range evaluation: & &step mode /*/ not allowed for integer variable") case default call range%write () call msg_bug ("range evaluation: step mode not implemented") end select end if end subroutine range_int_evaluate @ %def range_int_evaluate @ The version for a real variable. <>= procedure :: evaluate => range_real_evaluate <>= subroutine range_real_evaluate (range) class(range_real_t), intent(inout) :: range if (associated (range%pn_beg)) then call range%expr_beg%evaluate () if (range%expr_beg%is_known ()) then range%r_beg = range%expr_beg%get_real () else call range%write () call msg_fatal & ("Range expression: initial value evaluates to unknown") end if if (associated (range%pn_end)) then call range%expr_end%evaluate () if (range%expr_end%is_known ()) then range%r_end = range%expr_end%get_real () if (associated (range%pn_step)) then if (range%expr_step%is_known ()) then select case (range%step_mode) case (STEP_ADD, STEP_SUB, STEP_MUL, STEP_DIV) call range%expr_step%evaluate () range%r_step = range%expr_step%get_real () select case (range%step_mode) case (STEP_SUB); range%r_step = - range%r_step end select case (STEP_COMP_ADD, STEP_COMP_MUL) range%n_step = & max (range%expr_step%get_int (), 0) end select else call range%write () call msg_fatal & ("Range expression: step value evaluates to unknown") end if else call range%write () call msg_fatal & ("Range expression (real): step value must be provided") end if else call range%write () call msg_fatal & ("Range expression: final value evaluates to unknown") end if else range%r_end = range%r_beg range%r_step = 1 end if select case (range%step_mode) case (STEP_NONE) range%n_step = 1 case (STEP_ADD, STEP_SUB) if (range%r_step /= 0) then if (sign (1._default, range%r_end - range%r_beg) & == sign (1._default, range%r_step)) then range%n_step = & nint ((range%r_end - range%r_beg) / range%r_step + 1) else range%n_step = 0 end if else call msg_fatal ("range evaluation (add): step value is zero") end if case (STEP_MUL) if (range%r_step > 1) then if (range%r_beg == 0 .or. range%r_end == 0) then call msg_fatal ("range evaluation (mul): bound is zero") else if (sign (1._default, range%r_beg) & == sign (1._default, range%r_end) & .and. abs (range%r_beg) <= abs (range%r_end)) then range%lr_beg = log (abs (range%r_beg)) range%lr_end = log (abs (range%r_end)) range%lr_step = log (range%r_step) range%n_step = nint & (abs ((range%lr_end - range%lr_beg) / range%lr_step) + 1) else range%n_step = 0 end if else call msg_fatal & ("range evaluation (mult): step value is one or less") end if case (STEP_DIV) if (range%r_step > 1) then if (range%r_beg == 0 .or. range%r_end == 0) then call msg_fatal ("range evaluation (div): bound is zero") else if (sign (1._default, range%r_beg) & == sign (1._default, range%r_end) & .and. abs (range%r_beg) >= abs (range%r_end)) then range%lr_beg = log (abs (range%r_beg)) range%lr_end = log (abs (range%r_end)) range%lr_step = -log (range%r_step) range%n_step = nint & (abs ((range%lr_end - range%lr_beg) / range%lr_step) + 1) else range%n_step = 0 end if else call msg_fatal & ("range evaluation (mult): step value is one or less") end if case (STEP_COMP_ADD) ! Number of steps already known case (STEP_COMP_MUL) ! Number of steps already known if (range%r_beg == 0 .or. range%r_end == 0) then call msg_fatal ("range evaluation (mul): bound is zero") else if (sign (1._default, range%r_beg) & == sign (1._default, range%r_end)) then range%lr_beg = log (abs (range%r_beg)) range%lr_end = log (abs (range%r_end)) else range%n_step = 0 end if case default call range%write () call msg_bug ("range evaluation: step mode not implemented") end select end if end subroutine range_real_evaluate @ %def range_real_evaluate @ Return the number of iterations: <>= procedure :: get_n_iterations => range_get_n_iterations <>= function range_get_n_iterations (range) result (n) class(range_t), intent(in) :: range integer :: n n = range%n_step end function range_get_n_iterations @ %def range_get_n_iterations @ Compute the value for iteration [[i]] and store it in the embedded token. <>= procedure (range_set_value), deferred :: set_value <>= abstract interface subroutine range_set_value (range, i) import class(range_t), intent(inout) :: range integer, intent(in) :: i end subroutine range_set_value end interface @ %def range_set_value @ In the integer case, we compute the value directly for additive step. For multiplicative step, we perform a loop in the same way as above, where the number of iteration was determined. <>= procedure :: set_value => range_int_set_value <>= subroutine range_int_set_value (range, i) class(range_int_t), intent(inout) :: range integer, intent(in) :: i integer :: k, ival select case (range%step_mode) case (STEP_NONE) ival = range%i_beg case (STEP_ADD, STEP_SUB) ival = range%i_beg + (i - 1) * range%i_step case (STEP_MUL) ival = range%i_beg do k = 1, i - 1 ival = ival * range%i_step end do case (STEP_DIV) ival = range%i_beg do k = 1, i - 1 ival = ival / range%i_step end do case default call range%write () call msg_bug ("range iteration: step mode not implemented") end select call parse_node_set_value (range%pn_literal, ival = ival) end subroutine range_int_set_value @ %def range_int_set_value @ In the integer case, we compute the value directly for additive step. For multiplicative step, we perform a loop in the same way as above, where the number of iteration was determined. <>= procedure :: set_value => range_real_set_value <>= subroutine range_real_set_value (range, i) class(range_real_t), intent(inout) :: range integer, intent(in) :: i real(default) :: rval, x select case (range%step_mode) case (STEP_NONE) rval = range%r_beg case (STEP_ADD, STEP_SUB, STEP_COMP_ADD) if (range%n_step > 1) then x = real (i - 1, default) / (range%n_step - 1) else x = 1._default / 2 end if rval = x * range%r_end + (1 - x) * range%r_beg case (STEP_MUL, STEP_DIV, STEP_COMP_MUL) if (range%n_step > 1) then x = real (i - 1, default) / (range%n_step - 1) else x = 1._default / 2 end if rval = sign & (exp (x * range%lr_end + (1 - x) * range%lr_beg), range%r_beg) case default call range%write () call msg_bug ("range iteration: step mode not implemented") end select call parse_node_set_value (range%pn_literal, rval = rval) end subroutine range_real_set_value @ %def range_real_set_value @ \subsubsection{Scan over parameters and other objects} The scan command allocates a new parse node for the variable assignment (the lhs). The rhs of this parse node is assigned from the available rhs expressions in the scan list, one at a time, so the compiled parse node can be prepended to the scan body. Note: for the integer/real range array, the obvious implementation as a polymorphic array is suspended because in gfortran 4.7, polymorphic arrays are apparently broken. <>= type, extends (command_t) :: cmd_scan_t private type(string_t) :: name integer :: n_values = 0 type(parse_node_p), dimension(:), allocatable :: scan_cmd !!! !!! gfortran 4.7.x memory corruption !!! class(range_t), dimension(:), allocatable :: range type(range_int_t), dimension(:), allocatable :: range_int type(range_real_t), dimension(:), allocatable :: range_real contains <> end type cmd_scan_t @ %def cmd_scan_t @ Finalizer. The auxiliary parse nodes that we have constructed have to be treated carefully: the embedded pointers all point to persistent objects somewhere else and should not be finalized, so we should not call the finalizer recursively. <>= procedure :: final => cmd_scan_final <>= recursive subroutine cmd_scan_final (cmd) class(cmd_scan_t), intent(inout) :: cmd type(parse_node_t), pointer :: pn_var_single, pn_decl_single type(string_t) :: key integer :: i if (allocated (cmd%scan_cmd)) then do i = 1, size (cmd%scan_cmd) pn_var_single => parse_node_get_sub_ptr (cmd%scan_cmd(i)%ptr) key = parse_node_get_rule_key (pn_var_single) select case (char (key)) case ("scan_string_decl", "scan_log_decl") pn_decl_single => parse_node_get_sub_ptr (pn_var_single, 2) call parse_node_final (pn_decl_single, recursive=.false.) deallocate (pn_decl_single) end select call parse_node_final (pn_var_single, recursive=.false.) deallocate (pn_var_single) end do deallocate (cmd%scan_cmd) end if !!! !!! gfortran 4.7.x memory corruption !!! if (allocated (cmd%range)) then !!! do i = 1, size (cmd%range) !!! call cmd%range(i)%final () !!! end do !!! end if if (allocated (cmd%range_int)) then do i = 1, size (cmd%range_int) call cmd%range_int(i)%final () end do end if if (allocated (cmd%range_real)) then do i = 1, size (cmd%range_real) call cmd%range_real(i)%final () end do end if end subroutine cmd_scan_final @ %def cmd_scan_final @ Output. <>= procedure :: write => cmd_scan_write <>= subroutine cmd_scan_write (cmd, unit, indent) class(cmd_scan_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,1x,A,1x,'(',I0,')')") "scan:", char (cmd%name), & cmd%n_values end subroutine cmd_scan_write @ %def cmd_scan_write @ Compile the scan command. We construct a new parse node that implements the variable assignment for a single element on the rhs, instead of the whole list that we get from the original parse tree. By simply copying the node, we copy all pointers and inherit the targets from the original. During execution, we should replace the rhs by the stored rhs pointers (the list elements), one by one, then (re)compile the redefined node. <>= procedure :: compile => cmd_scan_compile <>= recursive subroutine cmd_scan_compile (cmd, global) class(cmd_scan_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list type(parse_node_t), pointer :: pn_var, pn_body, pn_body_first type(parse_node_t), pointer :: pn_decl, pn_name type(parse_node_t), pointer :: pn_arg, pn_scan_cmd, pn_rhs type(parse_node_t), pointer :: pn_decl_single, pn_var_single type(syntax_rule_t), pointer :: var_rule_decl, var_rule type(string_t) :: key integer :: var_type integer :: i call msg_debug (D_CORE, "cmd_scan_compile") if (debug_active (D_CORE)) call parse_node_write_rec (cmd%pn) pn_var => parse_node_get_sub_ptr (cmd%pn, 2) pn_body => parse_node_get_next_ptr (pn_var) if (associated (pn_body)) then pn_body_first => parse_node_get_sub_ptr (pn_body) else pn_body_first => null () end if key = parse_node_get_rule_key (pn_var) select case (char (key)) case ("scan_num") pn_name => parse_node_get_sub_ptr (pn_var) cmd%name = parse_node_get_string (pn_name) var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str ("cmd_num")) pn_arg => parse_node_get_next_ptr (pn_name, 2) case ("scan_int") pn_name => parse_node_get_sub_ptr (pn_var, 2) cmd%name = parse_node_get_string (pn_name) var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str ("cmd_int")) pn_arg => parse_node_get_next_ptr (pn_name, 2) case ("scan_real") pn_name => parse_node_get_sub_ptr (pn_var, 2) cmd%name = parse_node_get_string (pn_name) var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str ("cmd_real")) pn_arg => parse_node_get_next_ptr (pn_name, 2) case ("scan_complex") pn_name => parse_node_get_sub_ptr (pn_var, 2) cmd%name = parse_node_get_string (pn_name) var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str("cmd_complex")) pn_arg => parse_node_get_next_ptr (pn_name, 2) case ("scan_alias") pn_name => parse_node_get_sub_ptr (pn_var, 2) cmd%name = parse_node_get_string (pn_name) var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str ("cmd_alias")) pn_arg => parse_node_get_next_ptr (pn_name, 2) case ("scan_string_decl") pn_decl => parse_node_get_sub_ptr (pn_var, 2) pn_name => parse_node_get_sub_ptr (pn_decl, 2) cmd%name = parse_node_get_string (pn_name) var_rule_decl => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_string")) var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_string_decl")) pn_arg => parse_node_get_next_ptr (pn_name, 2) case ("scan_log_decl") pn_decl => parse_node_get_sub_ptr (pn_var, 2) pn_name => parse_node_get_sub_ptr (pn_decl, 2) cmd%name = parse_node_get_string (pn_name) var_rule_decl => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_log")) var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_log_decl")) pn_arg => parse_node_get_next_ptr (pn_name, 2) case ("scan_cuts") var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_cuts")) cmd%name = "cuts" pn_arg => parse_node_get_sub_ptr (pn_var, 3) case ("scan_weight") var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_weight")) cmd%name = "weight" pn_arg => parse_node_get_sub_ptr (pn_var, 3) case ("scan_scale") var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_scale")) cmd%name = "scale" pn_arg => parse_node_get_sub_ptr (pn_var, 3) case ("scan_ren_scale") var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_ren_scale")) cmd%name = "renormalization_scale" pn_arg => parse_node_get_sub_ptr (pn_var, 3) case ("scan_fac_scale") var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_fac_scale")) cmd%name = "factorization_scale" pn_arg => parse_node_get_sub_ptr (pn_var, 3) case ("scan_selection") var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_selection")) cmd%name = "selection" pn_arg => parse_node_get_sub_ptr (pn_var, 3) case ("scan_reweight") var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_reweight")) cmd%name = "reweight" pn_arg => parse_node_get_sub_ptr (pn_var, 3) case ("scan_analysis") var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_analysis")) cmd%name = "analysis" pn_arg => parse_node_get_sub_ptr (pn_var, 3) case ("scan_model") var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_model")) cmd%name = "model" pn_arg => parse_node_get_sub_ptr (pn_var, 3) case ("scan_library") var_rule => syntax_get_rule_ptr (syntax_cmd_list, & var_str ("cmd_library")) cmd%name = "library" pn_arg => parse_node_get_sub_ptr (pn_var, 3) case default call msg_bug ("scan: case '" // char (key) // "' not implemented") end select if (associated (pn_arg)) then cmd%n_values = parse_node_get_n_sub (pn_arg) end if var_list => global%get_var_list_ptr () allocate (cmd%scan_cmd (cmd%n_values)) select case (char (key)) case ("scan_num") var_type = & var_list%get_type (cmd%name) select case (var_type) case (V_INT) !!! !!! gfortran 4.7.x memory corruption !!! allocate (range_int_t :: cmd%range (cmd%n_values)) allocate (cmd%range_int (cmd%n_values)) case (V_REAL) !!! !!! gfortran 4.7.x memory corruption !!! allocate (range_real_t :: cmd%range (cmd%n_values)) allocate (cmd%range_real (cmd%n_values)) case (V_CMPLX) call msg_fatal ("scan over complex variable not implemented") case (V_NONE) call msg_fatal ("scan: variable '" // char (cmd%name) //"' undefined") case default call msg_bug ("scan: impossible variable type") end select case ("scan_int") !!! !!! gfortran 4.7.x memory corruption !!! allocate (range_int_t :: cmd%range (cmd%n_values)) allocate (cmd%range_int (cmd%n_values)) case ("scan_real") !!! !!! gfortran 4.7.x memory corruption !!! allocate (range_real_t :: cmd%range (cmd%n_values)) allocate (cmd%range_real (cmd%n_values)) case ("scan_complex") call msg_fatal ("scan over complex variable not implemented") end select i = 1 if (associated (pn_arg)) then pn_rhs => parse_node_get_sub_ptr (pn_arg) else pn_rhs => null () end if do while (associated (pn_rhs)) allocate (pn_scan_cmd) call parse_node_create_branch (pn_scan_cmd, & syntax_get_rule_ptr (syntax_cmd_list, var_str ("command_list"))) allocate (pn_var_single) pn_var_single = pn_var call parse_node_replace_rule (pn_var_single, var_rule) select case (char (key)) case ("scan_num", "scan_int", "scan_real", & "scan_complex", "scan_alias", & "scan_cuts", "scan_weight", & "scan_scale", "scan_ren_scale", "scan_fac_scale", & "scan_selection", "scan_reweight", "scan_analysis", & "scan_model", "scan_library") if (allocated (cmd%range_int)) then call cmd%range_int(i)%init (pn_rhs) !!! !!! gfortran 4.7.x memory corruption !!! call cmd%range_int(i)%compile (global) call parse_node_replace_last_sub & (pn_var_single, cmd%range_int(i)%pn_expr) else if (allocated (cmd%range_real)) then call cmd%range_real(i)%init (pn_rhs) !!! !!! gfortran 4.7.x memory corruption !!! call cmd%range_real(i)%compile (global) call parse_node_replace_last_sub & (pn_var_single, cmd%range_real(i)%pn_expr) else call parse_node_replace_last_sub (pn_var_single, pn_rhs) end if case ("scan_string_decl", "scan_log_decl") allocate (pn_decl_single) pn_decl_single = pn_decl call parse_node_replace_rule (pn_decl_single, var_rule_decl) call parse_node_replace_last_sub (pn_decl_single, pn_rhs) call parse_node_freeze_branch (pn_decl_single) call parse_node_replace_last_sub (pn_var_single, pn_decl_single) case default call msg_bug ("scan: case '" // char (key) & // "' broken") end select call parse_node_freeze_branch (pn_var_single) call parse_node_append_sub (pn_scan_cmd, pn_var_single) call parse_node_append_sub (pn_scan_cmd, pn_body_first) call parse_node_freeze_branch (pn_scan_cmd) cmd%scan_cmd(i)%ptr => pn_scan_cmd i = i + 1 pn_rhs => parse_node_get_next_ptr (pn_rhs) end do if (debug_active (D_CORE)) then do i = 1, cmd%n_values print *, "scan command ", i call parse_node_write_rec (cmd%scan_cmd(i)%ptr) if (allocated (cmd%range_int)) call cmd%range_int(i)%write () if (allocated (cmd%range_real)) call cmd%range_real(i)%write () end do print *, "original" call parse_node_write_rec (cmd%pn) end if end subroutine cmd_scan_compile @ %def cmd_scan_compile @ Execute the loop for all values in the step list. We use the parse trees with single variable assignment that we have stored, to iteratively create a local environment, execute the stored commands, and destroy it again. When we encounter a range object, we execute the commands for each value that this object provides. Computing this value has the side effect of modifying the rhs of the variable assignment that heads the local command list, directly in the local parse tree. <>= procedure :: execute => cmd_scan_execute <>= recursive subroutine cmd_scan_execute (cmd, global) class(cmd_scan_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(rt_data_t), allocatable :: local integer :: i, j do i = 1, cmd%n_values if (allocated (cmd%range_int)) then call cmd%range_int(i)%compile (global) call cmd%range_int(i)%evaluate () do j = 1, cmd%range_int(i)%get_n_iterations () call cmd%range_int(i)%set_value (j) allocate (local) call build_alt_setup (local, global, cmd%scan_cmd(i)%ptr) call local%local_final () deallocate (local) end do else if (allocated (cmd%range_real)) then call cmd%range_real(i)%compile (global) call cmd%range_real(i)%evaluate () do j = 1, cmd%range_real(i)%get_n_iterations () call cmd%range_real(i)%set_value (j) allocate (local) call build_alt_setup (local, global, cmd%scan_cmd(i)%ptr) call local%local_final () deallocate (local) end do else allocate (local) call build_alt_setup (local, global, cmd%scan_cmd(i)%ptr) call local%local_final () deallocate (local) end if end do end subroutine cmd_scan_execute @ %def cmd_scan_execute @ \subsubsection{Conditionals} Conditionals are implemented as a list that is compiled and evaluated recursively; this allows for a straightforward representation of [[else if]] constructs. A [[cmd_if_t]] object can hold either an [[else_if]] clause which is another object of this type, or an [[else_body]], but not both. If- or else-bodies are no scoping units, so all data remain global and no copy-in copy-out is needed. <>= type, extends (command_t) :: cmd_if_t private type(parse_node_t), pointer :: pn_if_lexpr => null () type(command_list_t), pointer :: if_body => null () type(cmd_if_t), dimension(:), pointer :: elsif_cmd => null () type(command_list_t), pointer :: else_body => null () contains <> end type cmd_if_t @ %def cmd_if_t @ Finalizer. There are no local options, therefore we can simply override the default finalizer. <>= procedure :: final => cmd_if_final <>= recursive subroutine cmd_if_final (cmd) class(cmd_if_t), intent(inout) :: cmd integer :: i if (associated (cmd%if_body)) then call command_list_final (cmd%if_body) deallocate (cmd%if_body) end if if (associated (cmd%elsif_cmd)) then do i = 1, size (cmd%elsif_cmd) call cmd_if_final (cmd%elsif_cmd(i)) end do deallocate (cmd%elsif_cmd) end if if (associated (cmd%else_body)) then call command_list_final (cmd%else_body) deallocate (cmd%else_body) end if end subroutine cmd_if_final @ %def cmd_if_final @ Output. Recursively write the command lists. <>= procedure :: write => cmd_if_write <>= subroutine cmd_if_write (cmd, unit, indent) class(cmd_if_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, ind, i u = given_output_unit (unit); if (u < 0) return ind = 0; if (present (indent)) ind = indent call write_indent (u, indent) write (u, "(A)") "if then" if (associated (cmd%if_body)) then call cmd%if_body%write (unit, ind + 1) end if if (associated (cmd%elsif_cmd)) then do i = 1, size (cmd%elsif_cmd) call write_indent (u, indent) write (u, "(A)") "elsif then" if (associated (cmd%elsif_cmd(i)%if_body)) then call cmd%elsif_cmd(i)%if_body%write (unit, ind + 1) end if end do end if if (associated (cmd%else_body)) then call write_indent (u, indent) write (u, "(A)") "else" call cmd%else_body%write (unit, ind + 1) end if end subroutine cmd_if_write @ %def cmd_if_write @ Compile the conditional. <>= procedure :: compile => cmd_if_compile <>= recursive subroutine cmd_if_compile (cmd, global) class(cmd_if_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_lexpr, pn_body type(parse_node_t), pointer :: pn_elsif_clauses, pn_cmd_elsif type(parse_node_t), pointer :: pn_else_clause, pn_cmd_else integer :: i, n_elsif pn_lexpr => parse_node_get_sub_ptr (cmd%pn, 2) cmd%pn_if_lexpr => pn_lexpr pn_body => parse_node_get_next_ptr (pn_lexpr, 2) select case (char (parse_node_get_rule_key (pn_body))) case ("command_list") allocate (cmd%if_body) call cmd%if_body%compile (pn_body, global) pn_elsif_clauses => parse_node_get_next_ptr (pn_body) case default pn_elsif_clauses => pn_body end select select case (char (parse_node_get_rule_key (pn_elsif_clauses))) case ("elsif_clauses") n_elsif = parse_node_get_n_sub (pn_elsif_clauses) allocate (cmd%elsif_cmd (n_elsif)) pn_cmd_elsif => parse_node_get_sub_ptr (pn_elsif_clauses) do i = 1, n_elsif pn_lexpr => parse_node_get_sub_ptr (pn_cmd_elsif, 2) cmd%elsif_cmd(i)%pn_if_lexpr => pn_lexpr pn_body => parse_node_get_next_ptr (pn_lexpr, 2) if (associated (pn_body)) then allocate (cmd%elsif_cmd(i)%if_body) call cmd%elsif_cmd(i)%if_body%compile (pn_body, global) end if pn_cmd_elsif => parse_node_get_next_ptr (pn_cmd_elsif) end do pn_else_clause => parse_node_get_next_ptr (pn_elsif_clauses) case default pn_else_clause => pn_elsif_clauses end select select case (char (parse_node_get_rule_key (pn_else_clause))) case ("else_clause") pn_cmd_else => parse_node_get_sub_ptr (pn_else_clause) pn_body => parse_node_get_sub_ptr (pn_cmd_else, 2) if (associated (pn_body)) then allocate (cmd%else_body) call cmd%else_body%compile (pn_body, global) end if end select end subroutine cmd_if_compile @ %def global @ (Recursively) execute the condition. Context remains global in all cases. <>= procedure :: execute => cmd_if_execute <>= recursive subroutine cmd_if_execute (cmd, global) class(cmd_if_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list logical :: lval, is_known integer :: i var_list => global%get_var_list_ptr () lval = eval_log (cmd%pn_if_lexpr, var_list, is_known=is_known) if (is_known) then if (lval) then if (associated (cmd%if_body)) then call cmd%if_body%execute (global) end if return end if else call error_undecided () return end if if (associated (cmd%elsif_cmd)) then SCAN_ELSIF: do i = 1, size (cmd%elsif_cmd) lval = eval_log (cmd%elsif_cmd(i)%pn_if_lexpr, var_list, & is_known=is_known) if (is_known) then if (lval) then if (associated (cmd%elsif_cmd(i)%if_body)) then call cmd%elsif_cmd(i)%if_body%execute (global) end if return end if else call error_undecided () return end if end do SCAN_ELSIF end if if (associated (cmd%else_body)) then call cmd%else_body%execute (global) end if contains subroutine error_undecided () call msg_error ("Undefined result of cmditional expression: " & // "neither branch will be executed") end subroutine error_undecided end subroutine cmd_if_execute @ %def cmd_if_execute @ \subsubsection{Include another command-list file} The include command allocates a local parse tree. This must not be deleted before the command object itself is deleted, since pointers may point to subobjects of it. <>= type, extends (command_t) :: cmd_include_t private type(string_t) :: file type(command_list_t), pointer :: command_list => null () type(parse_tree_t) :: parse_tree contains <> end type cmd_include_t @ %def cmd_include_t @ Finalizer: delete the command list. No options, so we can simply override the default finalizer. <>= procedure :: final => cmd_include_final <>= subroutine cmd_include_final (cmd) class(cmd_include_t), intent(inout) :: cmd call parse_tree_final (cmd%parse_tree) if (associated (cmd%command_list)) then call cmd%command_list%final () deallocate (cmd%command_list) end if end subroutine cmd_include_final @ %def cmd_include_final @ Write: display the command list as-is, if allocated. <>= procedure :: write => cmd_include_write <>= subroutine cmd_include_write (cmd, unit, indent) class(cmd_include_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call write_indent (u, indent) write (u, "(A,A,A,A)") "include ", '"', char (cmd%file), '"' if (associated (cmd%command_list)) then call cmd%command_list%write (u, ind + 1) end if end subroutine cmd_include_write @ %def cmd_include_write @ Compile file contents: First parse the file, then immediately compile its contents. Use the global data set. <>= procedure :: compile => cmd_include_compile <>= subroutine cmd_include_compile (cmd, global) class(cmd_include_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_arg, pn_file type(string_t) :: file logical :: exist integer :: u type(stream_t), target :: stream type(lexer_t) :: lexer pn_arg => parse_node_get_sub_ptr (cmd%pn, 2) pn_file => parse_node_get_sub_ptr (pn_arg) file = parse_node_get_string (pn_file) inquire (file=char(file), exist=exist) if (exist) then cmd%file = file else cmd%file = global%os_data%whizard_cutspath // "/" // file inquire (file=char(cmd%file), exist=exist) if (.not. exist) then call msg_error ("Include file '" // char (file) // "' not found") return end if end if u = free_unit () call lexer_init_cmd_list (lexer, global%lexer) call stream_init (stream, char (cmd%file)) call lexer_assign_stream (lexer, stream) call parse_tree_init (cmd%parse_tree, syntax_cmd_list, lexer) call stream_final (stream) call lexer_final (lexer) close (u) allocate (cmd%command_list) call cmd%command_list%compile (cmd%parse_tree%get_root_ptr (), & global) end subroutine cmd_include_compile @ %def cmd_include_compile @ Execute file contents in the global context. <>= procedure :: execute => cmd_include_execute <>= subroutine cmd_include_execute (cmd, global) class(cmd_include_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global if (associated (cmd%command_list)) then call msg_message & ("Including Sindarin from '" // char (cmd%file) // "'") call cmd%command_list%execute (global) call msg_message & ("End of included '" // char (cmd%file) // "'") end if end subroutine cmd_include_execute @ %def cmd_include_execute @ \subsubsection{Export values} This command exports the current values of variables or other objects to the surrounding scope. By default, a scope enclosed by braces keeps all objects local to it. The [[export]] command exports the values that are generated within the scope to the corresponding object in the outer scope. The allowed set of exportable objects is, in principle, the same as the set of objects that the [[show]] command supports. This includes some convenience abbreviations. TODO: The initial implementation inherits syntax from [[show]], but supports only the [[results]] pseudo-object. The results (i.e., the process stack) is appended to the outer process stack instead of being discarded. The behavior of the [[export]] command for other object kinds is to be defined on a case-by-case basis. It may involve replacing the outer value or, instead, doing some sort of appending or reduction. <>= type, extends (command_t) :: cmd_export_t private type(string_t), dimension(:), allocatable :: name contains <> end type cmd_export_t @ %def cmd_export_t @ Output: list the object names, not values. <>= procedure :: write => cmd_export_write <>= subroutine cmd_export_write (cmd, unit, indent) class(cmd_export_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u, i u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A)", advance="no") "export: " if (allocated (cmd%name)) then do i = 1, size (cmd%name) write (u, "(1x,A)", advance="no") char (cmd%name(i)) end do write (u, *) else write (u, "(5x,A)") "[undefined]" end if end subroutine cmd_export_write @ %def cmd_export_write @ Compile. Allocate an array which is filled with the names of the variables to export. <>= procedure :: compile => cmd_export_compile <>= subroutine cmd_export_compile (cmd, global) class(cmd_export_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_arg, pn_var, pn_prefix, pn_name type(string_t) :: key integer :: i, n_args pn_arg => parse_node_get_sub_ptr (cmd%pn, 2) if (associated (pn_arg)) then select case (char (parse_node_get_rule_key (pn_arg))) case ("show_arg") cmd%pn_opt => parse_node_get_next_ptr (pn_arg) case default cmd%pn_opt => pn_arg pn_arg => null () end select end if call cmd%compile_options (global) if (associated (pn_arg)) then n_args = parse_node_get_n_sub (pn_arg) allocate (cmd%name (n_args)) pn_var => parse_node_get_sub_ptr (pn_arg) i = 0 do while (associated (pn_var)) i = i + 1 select case (char (parse_node_get_rule_key (pn_var))) case ("model", "library", "beams", "iterations", & "cuts", "weight", "int", "real", "complex", & "scale", "factorization_scale", "renormalization_scale", & "selection", "reweight", "analysis", "pdg", & "stable", "unstable", "polarized", "unpolarized", & "results", "expect", "intrinsic", "string", "logical") cmd%name(i) = parse_node_get_key (pn_var) case ("result_var") pn_prefix => parse_node_get_sub_ptr (pn_var) pn_name => parse_node_get_next_ptr (pn_prefix) if (associated (pn_name)) then cmd%name(i) = parse_node_get_key (pn_prefix) & // "(" // parse_node_get_string (pn_name) // ")" else cmd%name(i) = parse_node_get_key (pn_prefix) end if case ("log_var", "string_var", "alias_var") pn_prefix => parse_node_get_sub_ptr (pn_var) pn_name => parse_node_get_next_ptr (pn_prefix) key = parse_node_get_key (pn_prefix) if (associated (pn_name)) then select case (char (parse_node_get_rule_key (pn_name))) case ("var_name") select case (char (key)) case ("?", "$") ! $ sign cmd%name(i) = key // parse_node_get_string (pn_name) case ("alias") cmd%name(i) = parse_node_get_string (pn_name) end select case default call parse_node_mismatch & ("var_name", pn_name) end select else cmd%name(i) = key end if case default cmd%name(i) = parse_node_get_string (pn_var) end select !!! restriction imposed by current lack of implementation select case (char (parse_node_get_rule_key (pn_var))) case ("results") case default call msg_fatal ("export: object (type) '" & // char (parse_node_get_rule_key (pn_var)) & // "' not supported yet") end select pn_var => parse_node_get_next_ptr (pn_var) end do else allocate (cmd%name (0)) end if end subroutine cmd_export_compile @ %def cmd_export_compile @ Execute. Scan the list of objects to export. <>= procedure :: execute => cmd_export_execute <>= subroutine cmd_export_execute (cmd, global) class(cmd_export_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global call global%append_exports (cmd%name) end subroutine cmd_export_execute @ %def cmd_export_execute @ \subsubsection{Quit command execution} The code is the return code of the whole program if it is terminated by this command. <>= type, extends (command_t) :: cmd_quit_t private logical :: has_code = .false. type(parse_node_t), pointer :: pn_code_expr => null () contains <> end type cmd_quit_t @ %def cmd_quit_t @ Output. <>= procedure :: write => cmd_quit_write <>= subroutine cmd_quit_write (cmd, unit, indent) class(cmd_quit_t), intent(in) :: cmd integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit); if (u < 0) return call write_indent (u, indent) write (u, "(1x,A,L1)") "quit: has_code = ", cmd%has_code end subroutine cmd_quit_write @ %def cmd_quit_write @ Compile: allocate a [[quit]] object which serves as a placeholder. <>= procedure :: compile => cmd_quit_compile <>= subroutine cmd_quit_compile (cmd, global) class(cmd_quit_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_arg pn_arg => parse_node_get_sub_ptr (cmd%pn, 2) if (associated (pn_arg)) then cmd%pn_code_expr => parse_node_get_sub_ptr (pn_arg) cmd%has_code = .true. end if end subroutine cmd_quit_compile @ %def cmd_quit_compile @ Execute: The quit command does not execute anything, it just stops command execution. This is achieved by setting quit flag and quit code in the global variable list. However, the return code, if present, is an expression which has to be evaluated. <>= procedure :: execute => cmd_quit_execute <>= subroutine cmd_quit_execute (cmd, global) class(cmd_quit_t), intent(inout) :: cmd type(rt_data_t), intent(inout), target :: global type(var_list_t), pointer :: var_list logical :: is_known var_list => global%get_var_list_ptr () if (cmd%has_code) then global%quit_code = eval_int (cmd%pn_code_expr, var_list, & is_known=is_known) if (.not. is_known) then call msg_error ("Undefined return code of quit/exit command") end if end if global%quit = .true. end subroutine cmd_quit_execute @ %def cmd_quit_execute @ \subsection{The command list} The command list holds a list of commands and relevant global data. <>= public :: command_list_t <>= type :: command_list_t ! not private anymore as required by the whizard-c-interface class(command_t), pointer :: first => null () class(command_t), pointer :: last => null () contains <> end type command_list_t @ %def command_list_t @ Output. <>= procedure :: write => command_list_write <>= recursive subroutine command_list_write (cmd_list, unit, indent) class(command_list_t), intent(in) :: cmd_list integer, intent(in), optional :: unit, indent class(command_t), pointer :: cmd cmd => cmd_list%first do while (associated (cmd)) call cmd%write (unit, indent) cmd => cmd%next end do end subroutine command_list_write @ %def command_list_write @ Append a new command to the list and free the original pointer. <>= procedure :: append => command_list_append <>= subroutine command_list_append (cmd_list, command) class(command_list_t), intent(inout) :: cmd_list class(command_t), intent(inout), pointer :: command if (associated (cmd_list%last)) then cmd_list%last%next => command else cmd_list%first => command end if cmd_list%last => command command => null () end subroutine command_list_append @ %def command_list_append @ Finalize. <>= procedure :: final => command_list_final <>= recursive subroutine command_list_final (cmd_list) class(command_list_t), intent(inout) :: cmd_list class(command_t), pointer :: command do while (associated (cmd_list%first)) command => cmd_list%first cmd_list%first => cmd_list%first%next call command%final () deallocate (command) end do cmd_list%last => null () end subroutine command_list_final @ %def command_list_final @ \subsection{Compiling the parse tree} Transform a parse tree into a command list. Initialization is assumed to be done. After each command, we set a breakpoint. <>= procedure :: compile => command_list_compile <>= recursive subroutine command_list_compile (cmd_list, pn, global) class(command_list_t), intent(inout), target :: cmd_list type(parse_node_t), intent(in), target :: pn type(rt_data_t), intent(inout), target :: global type(parse_node_t), pointer :: pn_cmd class(command_t), pointer :: command integer :: i pn_cmd => parse_node_get_sub_ptr (pn) do i = 1, parse_node_get_n_sub (pn) call dispatch_command (command, pn_cmd) call command%compile (global) call cmd_list%append (command) call terminate_now_if_signal () pn_cmd => parse_node_get_next_ptr (pn_cmd) end do end subroutine command_list_compile @ %def command_list_compile @ \subsection{Executing the command list} Before executing a command we should execute its options (if any). After that, reset the options, i.e., remove temporary effects from the global state. Also here, after each command we set a breakpoint. <>= procedure :: execute => command_list_execute <>= recursive subroutine command_list_execute (cmd_list, global) class(command_list_t), intent(in) :: cmd_list type(rt_data_t), intent(inout), target :: global class(command_t), pointer :: command command => cmd_list%first COMMAND_COND: do while (associated (command)) call command%execute_options (global) call command%execute (global) call command%reset_options (global) call terminate_now_if_signal () if (global%quit) exit COMMAND_COND command => command%next end do COMMAND_COND end subroutine command_list_execute @ %def command_list_execute @ \subsection{Command list syntax} <>= public :: syntax_cmd_list <>= type(syntax_t), target, save :: syntax_cmd_list @ %def syntax_cmd_list <>= public :: syntax_cmd_list_init <>= subroutine syntax_cmd_list_init () type(ifile_t) :: ifile call define_cmd_list_syntax (ifile) call syntax_init (syntax_cmd_list, ifile) call ifile_final (ifile) end subroutine syntax_cmd_list_init @ %def syntax_cmd_list_init <>= public :: syntax_cmd_list_final <>= subroutine syntax_cmd_list_final () call syntax_final (syntax_cmd_list) end subroutine syntax_cmd_list_final @ %def syntax_cmd_list_final <>= public :: syntax_cmd_list_write <>= subroutine syntax_cmd_list_write (unit) integer, intent(in), optional :: unit call syntax_write (syntax_cmd_list, unit) end subroutine syntax_cmd_list_write @ %def syntax_cmd_list_write <>= subroutine define_cmd_list_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "SEQ command_list = command*") call ifile_append (ifile, "ALT command = " & // "cmd_model | cmd_library | cmd_iterations | cmd_sample_format | " & // "cmd_var | cmd_slha | " & // "cmd_show | cmd_clear | " & // "cmd_expect | " & // "cmd_cuts | cmd_scale | cmd_fac_scale | cmd_ren_scale | " & // "cmd_weight | cmd_selection | cmd_reweight | " & // "cmd_beams | cmd_beams_pol_density | cmd_beams_pol_fraction | " & // "cmd_beams_momentum | cmd_beams_theta | cmd_beams_phi | " & // "cmd_integrate | " & // "cmd_observable | cmd_histogram | cmd_plot | cmd_graph | " & // "cmd_record | " & // "cmd_analysis | cmd_alt_setup | " & // "cmd_unstable | cmd_stable | cmd_simulate | cmd_rescan | " & // "cmd_process | cmd_compile | cmd_exec | " & // "cmd_scan | cmd_if | cmd_include | cmd_quit | " & // "cmd_export | " & // "cmd_polarized | cmd_unpolarized | " & // "cmd_open_out | cmd_close_out | cmd_printf | " & // "cmd_write_analysis | cmd_compile_analysis | cmd_nlo | cmd_components") call ifile_append (ifile, "GRO options = '{' local_command_list '}'") call ifile_append (ifile, "SEQ local_command_list = local_command*") call ifile_append (ifile, "ALT local_command = " & // "cmd_model | cmd_library | cmd_iterations | cmd_sample_format | " & // "cmd_var | cmd_slha | " & // "cmd_show | " & // "cmd_expect | " & // "cmd_cuts | cmd_scale | cmd_fac_scale | cmd_ren_scale | " & // "cmd_weight | cmd_selection | cmd_reweight | " & // "cmd_beams | cmd_beams_pol_density | cmd_beams_pol_fraction | " & // "cmd_beams_momentum | cmd_beams_theta | cmd_beams_phi | " & // "cmd_observable | cmd_histogram | cmd_plot | cmd_graph | " & // "cmd_clear | cmd_record | " & // "cmd_analysis | cmd_alt_setup | " & // "cmd_open_out | cmd_close_out | cmd_printf | " & // "cmd_write_analysis | cmd_compile_analysis | cmd_nlo | cmd_components") call ifile_append (ifile, "SEQ cmd_model = model '=' model_name model_arg?") call ifile_append (ifile, "KEY model") call ifile_append (ifile, "ALT model_name = model_id | string_literal") call ifile_append (ifile, "IDE model_id") call ifile_append (ifile, "ARG model_arg = ( model_scheme? )") call ifile_append (ifile, "ALT model_scheme = " & // "ufo_spec | scheme_id | string_literal") call ifile_append (ifile, "SEQ ufo_spec = ufo ufo_arg?") call ifile_append (ifile, "KEY ufo") call ifile_append (ifile, "ARG ufo_arg = ( string_literal )") call ifile_append (ifile, "IDE scheme_id") call ifile_append (ifile, "SEQ cmd_library = library '=' lib_name") call ifile_append (ifile, "KEY library") call ifile_append (ifile, "ALT lib_name = lib_id | string_literal") call ifile_append (ifile, "IDE lib_id") call ifile_append (ifile, "ALT cmd_var = " & // "cmd_log_decl | cmd_log | " & // "cmd_int | cmd_real | cmd_complex | cmd_num | " & // "cmd_string_decl | cmd_string | cmd_alias | " & // "cmd_result") call ifile_append (ifile, "SEQ cmd_log_decl = logical cmd_log") call ifile_append (ifile, "SEQ cmd_log = '?' var_name '=' lexpr") call ifile_append (ifile, "SEQ cmd_int = int var_name '=' expr") call ifile_append (ifile, "SEQ cmd_real = real var_name '=' expr") call ifile_append (ifile, "SEQ cmd_complex = complex var_name '=' expr") call ifile_append (ifile, "SEQ cmd_num = var_name '=' expr") call ifile_append (ifile, "SEQ cmd_string_decl = string cmd_string") call ifile_append (ifile, "SEQ cmd_string = " & // "'$' var_name '=' sexpr") ! $ call ifile_append (ifile, "SEQ cmd_alias = alias var_name '=' cexpr") call ifile_append (ifile, "SEQ cmd_result = result '=' expr") call ifile_append (ifile, "SEQ cmd_slha = slha_action slha_arg options?") call ifile_append (ifile, "ALT slha_action = " & // "read_slha | write_slha") call ifile_append (ifile, "KEY read_slha") call ifile_append (ifile, "KEY write_slha") call ifile_append (ifile, "ARG slha_arg = ( string_literal )") call ifile_append (ifile, "SEQ cmd_show = show show_arg options?") call ifile_append (ifile, "KEY show") call ifile_append (ifile, "ARG show_arg = ( showable* )") call ifile_append (ifile, "ALT showable = " & // "model | library | beams | iterations | " & // "cuts | weight | logical | string | pdg | " & // "scale | factorization_scale | renormalization_scale | " & // "selection | reweight | analysis | " & // "stable | unstable | polarized | unpolarized | " & // "expect | intrinsic | int | real | complex | " & // "alias_var | string | results | result_var | " & // "log_var | string_var | var_name") call ifile_append (ifile, "KEY results") call ifile_append (ifile, "KEY intrinsic") call ifile_append (ifile, "SEQ alias_var = alias var_name") call ifile_append (ifile, "SEQ result_var = result_key result_arg?") call ifile_append (ifile, "SEQ log_var = '?' var_name") call ifile_append (ifile, "SEQ string_var = '$' var_name") ! $ call ifile_append (ifile, "SEQ cmd_clear = clear clear_arg options?") call ifile_append (ifile, "KEY clear") call ifile_append (ifile, "ARG clear_arg = ( clearable* )") call ifile_append (ifile, "ALT clearable = " & // "beams | iterations | " & // "cuts | weight | " & // "scale | factorization_scale | renormalization_scale | " & // "selection | reweight | analysis | " & // "unstable | polarized | " & // "expect | " & // "log_var | string_var | var_name") call ifile_append (ifile, "SEQ cmd_expect = expect expect_arg options?") call ifile_append (ifile, "KEY expect") call ifile_append (ifile, "ARG expect_arg = ( lexpr )") call ifile_append (ifile, "SEQ cmd_cuts = cuts '=' lexpr") call ifile_append (ifile, "SEQ cmd_scale = scale '=' expr") call ifile_append (ifile, "SEQ cmd_fac_scale = " & // "factorization_scale '=' expr") call ifile_append (ifile, "SEQ cmd_ren_scale = " & // "renormalization_scale '=' expr") call ifile_append (ifile, "SEQ cmd_weight = weight '=' expr") call ifile_append (ifile, "SEQ cmd_selection = selection '=' lexpr") call ifile_append (ifile, "SEQ cmd_reweight = reweight '=' expr") call ifile_append (ifile, "KEY cuts") call ifile_append (ifile, "KEY scale") call ifile_append (ifile, "KEY factorization_scale") call ifile_append (ifile, "KEY renormalization_scale") call ifile_append (ifile, "KEY weight") call ifile_append (ifile, "KEY selection") call ifile_append (ifile, "KEY reweight") call ifile_append (ifile, "SEQ cmd_process = process process_id '=' " & // "process_prt '=>' prt_state_list options?") call ifile_append (ifile, "KEY process") call ifile_append (ifile, "KEY '=>'") call ifile_append (ifile, "LIS process_prt = cexpr+") call ifile_append (ifile, "LIS prt_state_list = prt_state_sum+") call ifile_append (ifile, "SEQ prt_state_sum = " & // "prt_state prt_state_addition*") call ifile_append (ifile, "SEQ prt_state_addition = '+' prt_state") call ifile_append (ifile, "ALT prt_state = grouped_prt_state_list | cexpr") call ifile_append (ifile, "GRO grouped_prt_state_list = " & // "( prt_state_list )") call ifile_append (ifile, "SEQ cmd_compile = compile_cmd options?") call ifile_append (ifile, "SEQ compile_cmd = compile_clause compile_arg?") call ifile_append (ifile, "SEQ compile_clause = compile exec_name_spec?") call ifile_append (ifile, "KEY compile") call ifile_append (ifile, "SEQ exec_name_spec = as exec_name") call ifile_append (ifile, "KEY as") call ifile_append (ifile, "ALT exec_name = exec_id | string_literal") call ifile_append (ifile, "IDE exec_id") call ifile_append (ifile, "ARG compile_arg = ( lib_name* )") call ifile_append (ifile, "SEQ cmd_exec = exec exec_arg") call ifile_append (ifile, "KEY exec") call ifile_append (ifile, "ARG exec_arg = ( sexpr )") call ifile_append (ifile, "SEQ cmd_beams = beams '=' beam_def") call ifile_append (ifile, "KEY beams") call ifile_append (ifile, "SEQ beam_def = beam_spec strfun_seq*") call ifile_append (ifile, "SEQ beam_spec = beam_list") call ifile_append (ifile, "LIS beam_list = cexpr, cexpr?") call ifile_append (ifile, "SEQ cmd_beams_pol_density = " & // "beams_pol_density '=' beams_pol_spec") call ifile_append (ifile, "KEY beams_pol_density") call ifile_append (ifile, "LIS beams_pol_spec = smatrix, smatrix?") call ifile_append (ifile, "SEQ smatrix = '@' smatrix_arg") ! call ifile_append (ifile, "KEY '@'") !!! Key already exists call ifile_append (ifile, "ARG smatrix_arg = ( sentry* )") call ifile_append (ifile, "SEQ sentry = expr extra_sentry*") call ifile_append (ifile, "SEQ extra_sentry = ':' expr") call ifile_append (ifile, "SEQ cmd_beams_pol_fraction = " & // "beams_pol_fraction '=' beams_par_spec") call ifile_append (ifile, "KEY beams_pol_fraction") call ifile_append (ifile, "SEQ cmd_beams_momentum = " & // "beams_momentum '=' beams_par_spec") call ifile_append (ifile, "KEY beams_momentum") call ifile_append (ifile, "SEQ cmd_beams_theta = " & // "beams_theta '=' beams_par_spec") call ifile_append (ifile, "KEY beams_theta") call ifile_append (ifile, "SEQ cmd_beams_phi = " & // "beams_phi '=' beams_par_spec") call ifile_append (ifile, "KEY beams_phi") call ifile_append (ifile, "LIS beams_par_spec = expr, expr?") call ifile_append (ifile, "SEQ strfun_seq = '=>' strfun_pair") call ifile_append (ifile, "LIS strfun_pair = strfun_def, strfun_def?") call ifile_append (ifile, "SEQ strfun_def = strfun_id") call ifile_append (ifile, "ALT strfun_id = " & // "none | lhapdf | lhapdf_photon | pdf_builtin | pdf_builtin_photon | " & // "isr | epa | ewa | circe1 | circe2 | energy_scan | " & // "gaussian | beam_events") call ifile_append (ifile, "KEY none") call ifile_append (ifile, "KEY lhapdf") call ifile_append (ifile, "KEY lhapdf_photon") call ifile_append (ifile, "KEY pdf_builtin") call ifile_append (ifile, "KEY pdf_builtin_photon") call ifile_append (ifile, "KEY isr") call ifile_append (ifile, "KEY epa") call ifile_append (ifile, "KEY ewa") call ifile_append (ifile, "KEY circe1") call ifile_append (ifile, "KEY circe2") call ifile_append (ifile, "KEY energy_scan") call ifile_append (ifile, "KEY gaussian") call ifile_append (ifile, "KEY beam_events") call ifile_append (ifile, "SEQ cmd_integrate = " & // "integrate proc_arg options?") call ifile_append (ifile, "KEY integrate") call ifile_append (ifile, "ARG proc_arg = ( proc_id* )") call ifile_append (ifile, "IDE proc_id") call ifile_append (ifile, "SEQ cmd_iterations = " & // "iterations '=' iterations_list") call ifile_append (ifile, "KEY iterations") call ifile_append (ifile, "LIS iterations_list = iterations_spec+") call ifile_append (ifile, "ALT iterations_spec = it_spec") call ifile_append (ifile, "SEQ it_spec = expr calls_spec adapt_spec?") call ifile_append (ifile, "SEQ calls_spec = ':' expr") call ifile_append (ifile, "SEQ adapt_spec = ':' sexpr") call ifile_append (ifile, "SEQ cmd_components = " & // "active '=' component_list") call ifile_append (ifile, "KEY active") call ifile_append (ifile, "LIS component_list = sexpr+") call ifile_append (ifile, "SEQ cmd_sample_format = " & // "sample_format '=' event_format_list") call ifile_append (ifile, "KEY sample_format") call ifile_append (ifile, "LIS event_format_list = event_format+") call ifile_append (ifile, "IDE event_format") call ifile_append (ifile, "SEQ cmd_observable = " & // "observable analysis_tag options?") call ifile_append (ifile, "KEY observable") call ifile_append (ifile, "SEQ cmd_histogram = " & // "histogram analysis_tag histogram_arg " & // "options?") call ifile_append (ifile, "KEY histogram") call ifile_append (ifile, "ARG histogram_arg = (expr, expr, expr?)") call ifile_append (ifile, "SEQ cmd_plot = plot analysis_tag options?") call ifile_append (ifile, "KEY plot") call ifile_append (ifile, "SEQ cmd_graph = graph graph_term '=' graph_def") call ifile_append (ifile, "KEY graph") call ifile_append (ifile, "SEQ graph_term = analysis_tag options?") call ifile_append (ifile, "SEQ graph_def = graph_term graph_append*") call ifile_append (ifile, "SEQ graph_append = '&' graph_term") call ifile_append (ifile, "SEQ cmd_analysis = analysis '=' lexpr") call ifile_append (ifile, "KEY analysis") call ifile_append (ifile, "SEQ cmd_alt_setup = " & // "alt_setup '=' option_list_expr") call ifile_append (ifile, "KEY alt_setup") call ifile_append (ifile, "ALT option_list_expr = " & // "grouped_option_list | option_list") call ifile_append (ifile, "GRO grouped_option_list = ( option_list_expr )") call ifile_append (ifile, "LIS option_list = options+") call ifile_append (ifile, "SEQ cmd_open_out = open_out open_arg options?") call ifile_append (ifile, "SEQ cmd_close_out = close_out open_arg options?") call ifile_append (ifile, "KEY open_out") call ifile_append (ifile, "KEY close_out") call ifile_append (ifile, "ARG open_arg = (sexpr)") call ifile_append (ifile, "SEQ cmd_printf = printf_cmd options?") call ifile_append (ifile, "SEQ printf_cmd = printf_clause sprintf_args?") call ifile_append (ifile, "SEQ printf_clause = printf sexpr") call ifile_append (ifile, "KEY printf") call ifile_append (ifile, "SEQ cmd_record = record_cmd") call ifile_append (ifile, "SEQ cmd_unstable = " & // "unstable cexpr unstable_arg options?") call ifile_append (ifile, "KEY unstable") call ifile_append (ifile, "ARG unstable_arg = ( proc_id* )") call ifile_append (ifile, "SEQ cmd_stable = stable stable_list options?") call ifile_append (ifile, "KEY stable") call ifile_append (ifile, "LIS stable_list = cexpr+") call ifile_append (ifile, "KEY polarized") call ifile_append (ifile, "SEQ cmd_polarized = polarized polarized_list options?") call ifile_append (ifile, "LIS polarized_list = cexpr+") call ifile_append (ifile, "KEY unpolarized") call ifile_append (ifile, "SEQ cmd_unpolarized = unpolarized unpolarized_list options?") call ifile_append (ifile, "LIS unpolarized_list = cexpr+") call ifile_append (ifile, "SEQ cmd_simulate = " & // "simulate proc_arg options?") call ifile_append (ifile, "KEY simulate") call ifile_append (ifile, "SEQ cmd_rescan = " & // "rescan sexpr proc_arg options?") call ifile_append (ifile, "KEY rescan") call ifile_append (ifile, "SEQ cmd_scan = scan scan_var scan_body?") call ifile_append (ifile, "KEY scan") call ifile_append (ifile, "ALT scan_var = " & // "scan_log_decl | scan_log | " & // "scan_int | scan_real | scan_complex | scan_num | " & // "scan_string_decl | scan_string | scan_alias | " & // "scan_cuts | scan_weight | " & // "scan_scale | scan_ren_scale | scan_fac_scale | " & // "scan_selection | scan_reweight | scan_analysis | " & // "scan_model | scan_library") call ifile_append (ifile, "SEQ scan_log_decl = logical scan_log") call ifile_append (ifile, "SEQ scan_log = '?' var_name '=' scan_log_arg") call ifile_append (ifile, "ARG scan_log_arg = ( lexpr* )") call ifile_append (ifile, "SEQ scan_int = int var_name '=' scan_num_arg") call ifile_append (ifile, "SEQ scan_real = real var_name '=' scan_num_arg") call ifile_append (ifile, "SEQ scan_complex = " & // "complex var_name '=' scan_num_arg") call ifile_append (ifile, "SEQ scan_num = var_name '=' scan_num_arg") call ifile_append (ifile, "ARG scan_num_arg = ( range* )") call ifile_append (ifile, "ALT range = grouped_range | range_expr") call ifile_append (ifile, "GRO grouped_range = ( range_expr )") call ifile_append (ifile, "SEQ range_expr = expr range_spec?") call ifile_append (ifile, "SEQ range_spec = '=>' expr step_spec?") call ifile_append (ifile, "SEQ step_spec = step_op expr") call ifile_append (ifile, "ALT step_op = " & // "'/+' | '/-' | '/*' | '//' | '/+/' | '/*/'") call ifile_append (ifile, "KEY '/+'") call ifile_append (ifile, "KEY '/-'") call ifile_append (ifile, "KEY '/*'") call ifile_append (ifile, "KEY '//'") call ifile_append (ifile, "KEY '/+/'") call ifile_append (ifile, "KEY '/*/'") call ifile_append (ifile, "SEQ scan_string_decl = string scan_string") call ifile_append (ifile, "SEQ scan_string = " & // "'$' var_name '=' scan_string_arg") call ifile_append (ifile, "ARG scan_string_arg = ( sexpr* )") call ifile_append (ifile, "SEQ scan_alias = " & // "alias var_name '=' scan_alias_arg") call ifile_append (ifile, "ARG scan_alias_arg = ( cexpr* )") call ifile_append (ifile, "SEQ scan_cuts = cuts '=' scan_lexpr_arg") call ifile_append (ifile, "ARG scan_lexpr_arg = ( lexpr* )") call ifile_append (ifile, "SEQ scan_scale = scale '=' scan_expr_arg") call ifile_append (ifile, "ARG scan_expr_arg = ( expr* )") call ifile_append (ifile, "SEQ scan_fac_scale = " & // "factorization_scale '=' scan_expr_arg") call ifile_append (ifile, "SEQ scan_ren_scale = " & // "renormalization_scale '=' scan_expr_arg") call ifile_append (ifile, "SEQ scan_weight = weight '=' scan_expr_arg") call ifile_append (ifile, "SEQ scan_selection = selection '=' scan_lexpr_arg") call ifile_append (ifile, "SEQ scan_reweight = reweight '=' scan_expr_arg") call ifile_append (ifile, "SEQ scan_analysis = analysis '=' scan_lexpr_arg") call ifile_append (ifile, "SEQ scan_model = model '=' scan_model_arg") call ifile_append (ifile, "ARG scan_model_arg = ( model_name* )") call ifile_append (ifile, "SEQ scan_library = library '=' scan_library_arg") call ifile_append (ifile, "ARG scan_library_arg = ( lib_name* )") call ifile_append (ifile, "GRO scan_body = '{' command_list '}'") call ifile_append (ifile, "SEQ cmd_if = " & // "if lexpr then command_list elsif_clauses else_clause endif") call ifile_append (ifile, "SEQ elsif_clauses = cmd_elsif*") call ifile_append (ifile, "SEQ cmd_elsif = elsif lexpr then command_list") call ifile_append (ifile, "SEQ else_clause = cmd_else?") call ifile_append (ifile, "SEQ cmd_else = else command_list") call ifile_append (ifile, "SEQ cmd_include = include include_arg") call ifile_append (ifile, "KEY include") call ifile_append (ifile, "ARG include_arg = ( string_literal )") call ifile_append (ifile, "SEQ cmd_quit = quit_cmd quit_arg?") call ifile_append (ifile, "ALT quit_cmd = quit | exit") call ifile_append (ifile, "KEY quit") call ifile_append (ifile, "KEY exit") call ifile_append (ifile, "ARG quit_arg = ( expr )") call ifile_append (ifile, "SEQ cmd_export = export show_arg options?") call ifile_append (ifile, "KEY export") call ifile_append (ifile, "SEQ cmd_write_analysis = " & // "write_analysis_clause options?") call ifile_append (ifile, "SEQ cmd_compile_analysis = " & // "compile_analysis_clause options?") call ifile_append (ifile, "SEQ write_analysis_clause = " & // "write_analysis write_analysis_arg?") call ifile_append (ifile, "SEQ compile_analysis_clause = " & // "compile_analysis write_analysis_arg?") call ifile_append (ifile, "KEY write_analysis") call ifile_append (ifile, "KEY compile_analysis") call ifile_append (ifile, "ARG write_analysis_arg = ( analysis_tag* )") call ifile_append (ifile, "SEQ cmd_nlo = " & // "nlo_calculation '=' nlo_calculation_list") call ifile_append (ifile, "KEY nlo_calculation") call ifile_append (ifile, "LIS nlo_calculation_list = nlo_comp+") call ifile_append (ifile, "ALT nlo_comp = " // & "full | born | real | virtual | dglap | subtraction | " // & "mismatch | GKS") call ifile_append (ifile, "KEY full") call ifile_append (ifile, "KEY born") call ifile_append (ifile, "KEY virtual") call ifile_append (ifile, "KEY dglap") call ifile_append (ifile, "KEY subtraction") call ifile_append (ifile, "KEY mismatch") call ifile_append (ifile, "KEY GKS") call define_expr_syntax (ifile, particles=.true., analysis=.true.) end subroutine define_cmd_list_syntax @ %def define_cmd_list_syntax <>= public :: lexer_init_cmd_list <>= subroutine lexer_init_cmd_list (lexer, parent_lexer) type(lexer_t), intent(out) :: lexer type(lexer_t), intent(in), optional, target :: parent_lexer call lexer_init (lexer, & comment_chars = "#!", & quote_chars = '"', & quote_match = '"', & single_chars = "()[]{},;:&%?$@", & special_class = [ "+-*/^", "<>=~ " ] , & keyword_list = syntax_get_keyword_list_ptr (syntax_cmd_list), & parent = parent_lexer) end subroutine lexer_init_cmd_list @ %def lexer_init_cmd_list @ \subsection{Unit Tests} Test module, followed by the corresponding implementation module. <<[[commands_ut.f90]]>>= <> module commands_ut use unit_tests use commands_uti <> <> contains <> end module commands_ut @ %def commands_ut @ <<[[commands_uti.f90]]>>= <> module commands_uti <> use kinds, only: i64 <> use io_units use ifiles use parser use interactions, only: reset_interaction_counter use prclib_stacks use analysis use variables, only: var_list_t use models use slha_interface use rt_data use event_base, only: generic_event_t, event_callback_t use commands <> <> <> contains <> <> end module commands_uti @ %def commands_uti @ API: driver for the unit tests below. <>= public :: commands_test <>= subroutine commands_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine commands_test @ %def commands_test @ \subsubsection{Prepare Sindarin code} This routine parses an internal file, prints the parse tree, and returns a parse node to the root. We use the routine in the tests below. <>= public :: parse_ifile <>= subroutine parse_ifile (ifile, pn_root, u) use ifiles use lexers use parser use commands type(ifile_t), intent(in) :: ifile type(parse_node_t), pointer, intent(out) :: pn_root integer, intent(in), optional :: u type(stream_t), target :: stream type(lexer_t), target :: lexer type(parse_tree_t) :: parse_tree call lexer_init_cmd_list (lexer) call stream_init (stream, ifile) call lexer_assign_stream (lexer, stream) call parse_tree_init (parse_tree, syntax_cmd_list, lexer) if (present (u)) call parse_tree_write (parse_tree, u) pn_root => parse_tree%get_root_ptr () call stream_final (stream) call lexer_final (lexer) end subroutine parse_ifile @ %def parse_ifile @ \subsubsection{Empty command list} Compile and execute an empty command list. Should do nothing but test the integrity of the workflow. <>= call test (commands_1, "commands_1", & "empty command list", & u, results) <>= public :: commands_1 <>= subroutine commands_1 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_1" write (u, "(A)") "* Purpose: compile and execute empty command list" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Parse empty file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" if (associated (pn_root)) then call command_list%compile (pn_root, global) end if write (u, "(A)") write (u, "(A)") "* Execute command list" call global%activate () call command_list%execute (global) call global%deactivate () write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call syntax_cmd_list_final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_1" end subroutine commands_1 @ %def commands_1 @ \subsubsection{Read model} Execute a [[model]] assignment. <>= call test (commands_2, "commands_2", & "model", & u, results) <>= public :: commands_2 <>= subroutine commands_2 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_2" write (u, "(A)") "* Purpose: set model" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_write (ifile, u) write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_2" end subroutine commands_2 @ %def commands_2 @ \subsubsection{Declare Process} Read a model, then declare a process. The process library is allocated explicitly. For the process definition, We take the default ([[omega]]) method. Since we do not compile, \oMega\ is not actually called. <>= call test (commands_3, "commands_3", & "process declaration", & u, results) <>= public :: commands_3 <>= subroutine commands_3 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(prclib_entry_t), pointer :: lib write (u, "(A)") "* Test output: commands_3" write (u, "(A)") "* Purpose: define process" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () call global%var_list%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) allocate (lib) call lib%init (var_str ("lib_cmd3")) call global%add_prclib (lib) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'process t3 = s, s => s, s') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%prclib_stack%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_3" end subroutine commands_3 @ %def commands_3 @ \subsubsection{Compile Process} Read a model, then declare a process and compile the library. The process library is allocated explicitly. For the process definition, We take the default ([[unit_test]]) method. There is no external code, so compilation of the library is merely a formal status change. <>= call test (commands_4, "commands_4", & "compilation", & u, results) <>= public :: commands_4 <>= subroutine commands_4 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(prclib_entry_t), pointer :: lib write (u, "(A)") "* Test output: commands_4" write (u, "(A)") "* Purpose: define process and compile library" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () call global%var_list%set_string (var_str ("$method"), & var_str ("unit_test"), is_known=.true.) allocate (lib) call lib%init (var_str ("lib_cmd4")) call global%add_prclib (lib) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'process t4 = s, s => s, s') call ifile_append (ifile, 'compile ("lib_cmd4")') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%prclib_stack%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_4" end subroutine commands_4 @ %def commands_4 @ \subsubsection{Integrate Process} Read a model, then declare a process, compile the library, and integrate over phase space. We take the default ([[unit_test]]) method and use the simplest methods of phase-space parameterization and integration. <>= call test (commands_5, "commands_5", & "integration", & u, results) <>= public :: commands_5 <>= subroutine commands_5 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(prclib_entry_t), pointer :: lib write (u, "(A)") "* Test output: commands_5" write (u, "(A)") "* Purpose: define process, iterations, and integrate" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () call global%var_list%set_string (var_str ("$method"), & var_str ("unit_test"), is_known=.true.) call global%var_list%set_string (var_str ("$phs_method"), & var_str ("single"), is_known=.true.) call global%var_list%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known=.true.) call global%var_list%set_log (var_str ("?vis_history"),& .false., is_known=.true.) call global%var_list%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%var_list%set_real (var_str ("sqrts"), & 1000._default, is_known=.true.) call global%var_list%set_int (var_str ("seed"), 0, is_known=.true.) allocate (lib) call lib%init (var_str ("lib_cmd5")) call global%add_prclib (lib) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'process t5 = s, s => s, s') call ifile_append (ifile, 'compile') call ifile_append (ifile, 'iterations = 1:1000') call ifile_append (ifile, 'integrate (t5)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call reset_interaction_counter () call command_list%execute (global) call global%it_list%write (u) write (u, "(A)") call global%process_stack%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_5" end subroutine commands_5 @ %def commands_5 @ \subsubsection{Variables} Set intrinsic and user-defined variables. <>= call test (commands_6, "commands_6", & "variables", & u, results) <>= public :: commands_6 <>= subroutine commands_6 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_6" write (u, "(A)") "* Purpose: define and set variables" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () call global%write_vars (u, [ & var_str ("$run_id"), & var_str ("?unweighted"), & var_str ("sqrts")]) write (u, "(A)") write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, '$run_id = "run1"') call ifile_append (ifile, '?unweighted = false') call ifile_append (ifile, 'sqrts = 1000') call ifile_append (ifile, 'int j = 10') call ifile_append (ifile, 'real x = 1000.') call ifile_append (ifile, 'complex z = 5') call ifile_append (ifile, 'string $text = "abcd"') call ifile_append (ifile, 'logical ?flag = true') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write_vars (u, [ & var_str ("$run_id"), & var_str ("?unweighted"), & var_str ("sqrts"), & var_str ("j"), & var_str ("x"), & var_str ("z"), & var_str ("$text"), & var_str ("?flag")]) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call syntax_cmd_list_final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_6" end subroutine commands_6 @ %def commands_6 @ \subsubsection{Process library} Open process libraries explicitly. <>= call test (commands_7, "commands_7", & "process library", & u, results) <>= public :: commands_7 <>= subroutine commands_7 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_7" write (u, "(A)") "* Purpose: declare process libraries" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () call global%var_list%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) global%os_data%fc = "Fortran-compiler" global%os_data%fcflags = "Fortran-flags" write (u, "(A)") write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'library = "lib_cmd7_1"') call ifile_append (ifile, 'library = "lib_cmd7_2"') call ifile_append (ifile, 'library = "lib_cmd7_1"') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write_libraries (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call syntax_cmd_list_final () call global%final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_7" end subroutine commands_7 @ %def commands_7 @ \subsubsection{Generate events} Read a model, then declare a process, compile the library, and generate weighted events. We take the default ([[unit_test]]) method and use the simplest methods of phase-space parameterization and integration. <>= call test (commands_8, "commands_8", & "event generation", & u, results) <>= public :: commands_8 <>= subroutine commands_8 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(prclib_entry_t), pointer :: lib write (u, "(A)") "* Test output: commands_8" write (u, "(A)") "* Purpose: define process, integrate, generate events" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call global%var_list%set_string (var_str ("$method"), & var_str ("unit_test"), is_known=.true.) call global%var_list%set_string (var_str ("$phs_method"), & var_str ("single"), is_known=.true.) call global%var_list%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known=.true.) call global%var_list%set_log (var_str ("?vis_history"),& .false., is_known=.true.) call global%var_list%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%var_list%set_real (var_str ("sqrts"), & 1000._default, is_known=.true.) allocate (lib) call lib%init (var_str ("lib_cmd8")) call global%add_prclib (lib) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'process commands_8_p = s, s => s, s') call ifile_append (ifile, 'compile') call ifile_append (ifile, 'iterations = 1:1000') call ifile_append (ifile, 'integrate (commands_8_p)') call ifile_append (ifile, '?unweighted = false') call ifile_append (ifile, 'n_events = 3') call ifile_append (ifile, '?read_raw = false') call ifile_append (ifile, 'simulate (commands_8_p)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" call command_list%execute (global) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_8" end subroutine commands_8 @ %def commands_8 @ \subsubsection{Define cuts} Declare a cut expression. <>= call test (commands_9, "commands_9", & "cuts", & u, results) <>= public :: commands_9 <>= subroutine commands_9 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(string_t), dimension(0) :: no_vars write (u, "(A)") "* Test output: commands_9" write (u, "(A)") "* Purpose: define cuts" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'cuts = all Pt > 0 [particle]') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write (u, vars = no_vars) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_9" end subroutine commands_9 @ %def commands_9 @ \subsubsection{Beams} Define beam setup. <>= call test (commands_10, "commands_10", & "beams", & u, results) <>= public :: commands_10 <>= subroutine commands_10 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_10" write (u, "(A)") "* Purpose: define beams" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = QCD') call ifile_append (ifile, 'sqrts = 1000') call ifile_append (ifile, 'beams = p, p') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write_beams (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_10" end subroutine commands_10 @ %def commands_10 @ \subsubsection{Structure functions} Define beam setup with structure functions <>= call test (commands_11, "commands_11", & "structure functions", & u, results) <>= public :: commands_11 <>= subroutine commands_11 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_11" write (u, "(A)") "* Purpose: define beams with structure functions" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = QCD') call ifile_append (ifile, 'sqrts = 1100') call ifile_append (ifile, 'beams = p, p => lhapdf => pdf_builtin, isr') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write_beams (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_11" end subroutine commands_11 @ %def commands_11 @ \subsubsection{Rescan events} Read a model, then declare a process, compile the library, and generate weighted events. We take the default ([[unit_test]]) method and use the simplest methods of phase-space parameterization and integration. Then, rescan the generated event sample. <>= call test (commands_12, "commands_12", & "event rescanning", & u, results) <>= public :: commands_12 <>= subroutine commands_12 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(prclib_entry_t), pointer :: lib write (u, "(A)") "* Test output: commands_12" write (u, "(A)") "* Purpose: generate events and rescan" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () call global%var_list%append_log (& var_str ("?rebuild_phase_space"), .false., & intrinsic=.true.) call global%var_list%append_log (& var_str ("?rebuild_grids"), .false., & intrinsic=.true.) call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call global%var_list%set_string (var_str ("$method"), & var_str ("unit_test"), is_known=.true.) call global%var_list%set_string (var_str ("$phs_method"), & var_str ("single"), is_known=.true.) call global%var_list%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known=.true.) call global%var_list%set_log (var_str ("?vis_history"),& .false., is_known=.true.) call global%var_list%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%var_list%set_real (var_str ("sqrts"), & 1000._default, is_known=.true.) allocate (lib) call lib%init (var_str ("lib_cmd12")) call global%add_prclib (lib) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'process commands_12_p = s, s => s, s') call ifile_append (ifile, 'compile') call ifile_append (ifile, 'iterations = 1:1000') call ifile_append (ifile, 'integrate (commands_12_p)') call ifile_append (ifile, '?unweighted = false') call ifile_append (ifile, 'n_events = 3') call ifile_append (ifile, '?read_raw = false') call ifile_append (ifile, 'simulate (commands_12_p)') call ifile_append (ifile, '?write_raw = false') call ifile_append (ifile, 'rescan "commands_12_p" (commands_12_p)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" call command_list%execute (global) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_12" end subroutine commands_12 @ %def commands_12 @ \subsubsection{Event Files} Set output formats for event files. <>= call test (commands_13, "commands_13", & "event output formats", & u, results) <>= public :: commands_13 <>= subroutine commands_13 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(prclib_entry_t), pointer :: lib logical :: exist write (u, "(A)") "* Test output: commands_13" write (u, "(A)") "* Purpose: generate events and rescan" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call global%var_list%set_string (var_str ("$method"), & var_str ("unit_test"), is_known=.true.) call global%var_list%set_string (var_str ("$phs_method"), & var_str ("single"), is_known=.true.) call global%var_list%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known=.true.) call global%var_list%set_real (var_str ("sqrts"), & 1000._default, is_known=.true.) call global%var_list%set_log (var_str ("?vis_history"),& .false., is_known=.true.) call global%var_list%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) allocate (lib) call lib%init (var_str ("lib_cmd13")) call global%add_prclib (lib) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'process commands_13_p = s, s => s, s') call ifile_append (ifile, 'compile') call ifile_append (ifile, 'iterations = 1:1000') call ifile_append (ifile, 'integrate (commands_13_p)') call ifile_append (ifile, '?unweighted = false') call ifile_append (ifile, 'n_events = 1') call ifile_append (ifile, '?read_raw = false') call ifile_append (ifile, 'sample_format = weight_stream') call ifile_append (ifile, 'simulate (commands_13_p)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" call command_list%execute (global) write (u, "(A)") write (u, "(A)") "* Verify output files" write (u, "(A)") inquire (file = "commands_13_p.evx", exist = exist) if (exist) write (u, "(1x,A)") "raw" inquire (file = "commands_13_p.weights.dat", exist = exist) if (exist) write (u, "(1x,A)") "weight_stream" write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_13" end subroutine commands_13 @ %def commands_13 @ \subsubsection{Compile Empty Libraries} (This is a regression test:) Declare two empty libraries and compile them. <>= call test (commands_14, "commands_14", & "empty libraries", & u, results) <>= public :: commands_14 <>= subroutine commands_14 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_14" write (u, "(A)") "* Purpose: define and compile empty libraries" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_model_file_init () call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'library = "lib1"') call ifile_append (ifile, 'library = "lib2"') call ifile_append (ifile, 'compile ()') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%prclib_stack%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_14" end subroutine commands_14 @ %def commands_14 @ \subsubsection{Compile Process} Read a model, then declare a process and compile the library. The process library is allocated explicitly. For the process definition, We take the default ([[unit_test]]) method. There is no external code, so compilation of the library is merely a formal status change. <>= call test (commands_15, "commands_15", & "compilation", & u, results) <>= public :: commands_15 <>= subroutine commands_15 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(prclib_entry_t), pointer :: lib write (u, "(A)") "* Test output: commands_15" write (u, "(A)") "* Purpose: define process and compile library" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () call global%var_list%set_string (var_str ("$method"), & var_str ("unit_test"), is_known=.true.) call global%var_list%set_string (var_str ("$phs_method"), & var_str ("single"), is_known=.true.) call global%var_list%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known=.true.) call global%var_list%set_real (var_str ("sqrts"), & 1000._default, is_known=.true.) call global%var_list%set_log (var_str ("?vis_history"),& .false., is_known=.true.) call global%var_list%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) allocate (lib) call lib%init (var_str ("lib_cmd15")) call global%add_prclib (lib) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'process t15 = s, s => s, s') call ifile_append (ifile, 'iterations = 1:1000') call ifile_append (ifile, 'integrate (t15)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%prclib_stack%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_15" end subroutine commands_15 @ %def commands_15 @ \subsubsection{Observable} Declare an observable, fill it and display. <>= call test (commands_16, "commands_16", & "observables", & u, results) <>= public :: commands_16 <>= subroutine commands_16 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_16" write (u, "(A)") "* Purpose: declare an observable" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, '$obs_label = "foo"') call ifile_append (ifile, '$obs_unit = "cm"') call ifile_append (ifile, '$title = "Observable foo"') call ifile_append (ifile, '$description = "This is observable foo"') call ifile_append (ifile, 'observable foo') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Record two data items" write (u, "(A)") call analysis_record_data (var_str ("foo"), 1._default) call analysis_record_data (var_str ("foo"), 3._default) write (u, "(A)") "* Display analysis store" write (u, "(A)") call analysis_write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call analysis_final () call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_16" end subroutine commands_16 @ %def commands_16 @ \subsubsection{Histogram} Declare a histogram, fill it and display. <>= call test (commands_17, "commands_17", & "histograms", & u, results) <>= public :: commands_17 <>= subroutine commands_17 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(string_t), dimension(3) :: name integer :: i write (u, "(A)") "* Test output: commands_17" write (u, "(A)") "* Purpose: declare histograms" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, '$obs_label = "foo"') call ifile_append (ifile, '$obs_unit = "cm"') call ifile_append (ifile, '$title = "Histogram foo"') call ifile_append (ifile, '$description = "This is histogram foo"') call ifile_append (ifile, 'histogram foo (0,5,1)') call ifile_append (ifile, '$title = "Histogram bar"') call ifile_append (ifile, '$description = "This is histogram bar"') call ifile_append (ifile, 'n_bins = 2') call ifile_append (ifile, 'histogram bar (0,5)') call ifile_append (ifile, '$title = "Histogram gee"') call ifile_append (ifile, '$description = "This is histogram gee"') call ifile_append (ifile, '?normalize_bins = true') call ifile_append (ifile, 'histogram gee (0,5)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Record two data items" write (u, "(A)") name(1) = "foo" name(2) = "bar" name(3) = "gee" do i = 1, 3 call analysis_record_data (name(i), 0.1_default, & weight = 0.25_default) call analysis_record_data (name(i), 3.1_default) call analysis_record_data (name(i), 4.1_default, & excess = 0.5_default) call analysis_record_data (name(i), 7.1_default) end do write (u, "(A)") "* Display analysis store" write (u, "(A)") call analysis_write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call analysis_final () call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_17" end subroutine commands_17 @ %def commands_17 @ \subsubsection{Plot} Declare a plot, fill it and display contents. <>= call test (commands_18, "commands_18", & "plots", & u, results) <>= public :: commands_18 <>= subroutine commands_18 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_18" write (u, "(A)") "* Purpose: declare a plot" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, '$obs_label = "foo"') call ifile_append (ifile, '$obs_unit = "cm"') call ifile_append (ifile, '$title = "Plot foo"') call ifile_append (ifile, '$description = "This is plot foo"') call ifile_append (ifile, '$x_label = "x axis"') call ifile_append (ifile, '$y_label = "y axis"') call ifile_append (ifile, '?x_log = false') call ifile_append (ifile, '?y_log = true') call ifile_append (ifile, 'x_min = -1') call ifile_append (ifile, 'x_max = 1') call ifile_append (ifile, 'y_min = 0.1') call ifile_append (ifile, 'y_max = 1000') call ifile_append (ifile, 'plot foo') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Record two data items" write (u, "(A)") call analysis_record_data (var_str ("foo"), 0._default, 20._default, & xerr = 0.25_default) call analysis_record_data (var_str ("foo"), 0.5_default, 0.2_default, & yerr = 0.07_default) call analysis_record_data (var_str ("foo"), 3._default, 2._default) write (u, "(A)") "* Display analysis store" write (u, "(A)") call analysis_write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call analysis_final () call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_18" end subroutine commands_18 @ %def commands_18 @ \subsubsection{Graph} Combine two (empty) plots to a graph. <>= call test (commands_19, "commands_19", & "graphs", & u, results) <>= public :: commands_19 <>= subroutine commands_19 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_19" write (u, "(A)") "* Purpose: combine two plots to a graph" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'plot a') call ifile_append (ifile, 'plot b') call ifile_append (ifile, '$title = "Graph foo"') call ifile_append (ifile, '$description = "This is graph foo"') call ifile_append (ifile, 'graph foo = a & b') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Display analysis object" write (u, "(A)") call analysis_write (var_str ("foo"), u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call analysis_final () call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_19" end subroutine commands_19 @ %def commands_19 @ \subsubsection{Record Data} Record data in previously allocated analysis objects. <>= call test (commands_20, "commands_20", & "record data", & u, results) <>= public :: commands_20 <>= subroutine commands_20 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_20" write (u, "(A)") "* Purpose: record data" write (u, "(A)") write (u, "(A)") "* Initialization: create observable, histogram, plot" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () call analysis_init_observable (var_str ("o")) call analysis_init_histogram (var_str ("h"), 0._default, 1._default, 3, & normalize_bins = .false.) call analysis_init_plot (var_str ("p")) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'record o (1.234)') call ifile_append (ifile, 'record h (0.5)') call ifile_append (ifile, 'record p (1, 2)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Display analysis object" write (u, "(A)") call analysis_write (u, verbose = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call analysis_final () call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_20" end subroutine commands_20 @ %def commands_20 @ \subsubsection{Analysis} Declare an analysis expression and use it to fill an observable during event generation. <>= call test (commands_21, "commands_21", & "analysis expression", & u, results) <>= public :: commands_21 <>= subroutine commands_21 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(prclib_entry_t), pointer :: lib write (u, "(A)") "* Test output: commands_21" write (u, "(A)") "* Purpose: create and use analysis expression" write (u, "(A)") write (u, "(A)") "* Initialization: create observable" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call global%var_list%set_string (var_str ("$method"), & var_str ("unit_test"), is_known=.true.) call global%var_list%set_string (var_str ("$phs_method"), & var_str ("single"), is_known=.true.) call global%var_list%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known=.true.) call global%var_list%set_log (var_str ("?vis_history"),& .false., is_known=.true.) call global%var_list%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) call global%var_list%set_real (var_str ("sqrts"), & 1000._default, is_known=.true.) allocate (lib) call lib%init (var_str ("lib_cmd8")) call global%add_prclib (lib) call analysis_init_observable (var_str ("m")) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'process commands_21_p = s, s => s, s') call ifile_append (ifile, 'compile') call ifile_append (ifile, 'iterations = 1:100') call ifile_append (ifile, 'integrate (commands_21_p)') call ifile_append (ifile, '?unweighted = true') call ifile_append (ifile, 'n_events = 3') call ifile_append (ifile, '?read_raw = false') call ifile_append (ifile, 'observable m') call ifile_append (ifile, 'analysis = record m (eval M [s])') call ifile_append (ifile, 'simulate (commands_21_p)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Display analysis object" write (u, "(A)") call analysis_write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call analysis_final () call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_21" end subroutine commands_21 @ %def commands_21 @ \subsubsection{Write Analysis} Write accumulated analysis data to file. <>= call test (commands_22, "commands_22", & "write analysis", & u, results) <>= public :: commands_22 <>= subroutine commands_22 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root integer :: u_file, iostat logical :: exist character(80) :: buffer write (u, "(A)") "* Test output: commands_22" write (u, "(A)") "* Purpose: write analysis data" write (u, "(A)") write (u, "(A)") "* Initialization: create observable" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () call analysis_init_observable (var_str ("m")) call analysis_record_data (var_str ("m"), 125._default) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, '$out_file = "commands_22.dat"') call ifile_append (ifile, 'write_analysis') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Display analysis data" write (u, "(A)") inquire (file = "commands_22.dat", exist = exist) if (.not. exist) then write (u, "(A)") "ERROR: File commands_22.dat not found" return end if u_file = free_unit () open (u_file, file = "commands_22.dat", & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call analysis_final () call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_22" end subroutine commands_22 @ %def commands_22 @ \subsubsection{Compile Analysis} Write accumulated analysis data to file and compile. <>= call test (commands_23, "commands_23", & "compile analysis", & u, results) <>= public :: commands_23 <>= subroutine commands_23 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root integer :: u_file, iostat character(256) :: buffer logical :: exist type(graph_options_t) :: graph_options write (u, "(A)") "* Test output: commands_23" write (u, "(A)") "* Purpose: write and compile analysis data" write (u, "(A)") write (u, "(A)") "* Initialization: create and fill histogram" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () call graph_options_init (graph_options) call graph_options_set (graph_options, & title = var_str ("Histogram for test: commands 23"), & description = var_str ("This is a test."), & width_mm = 125, height_mm = 85) call analysis_init_histogram (var_str ("h"), & 0._default, 10._default, 2._default, .false., & graph_options = graph_options) call analysis_record_data (var_str ("h"), 1._default) call analysis_record_data (var_str ("h"), 1._default) call analysis_record_data (var_str ("h"), 1._default) call analysis_record_data (var_str ("h"), 1._default) call analysis_record_data (var_str ("h"), 3._default) call analysis_record_data (var_str ("h"), 3._default) call analysis_record_data (var_str ("h"), 3._default) call analysis_record_data (var_str ("h"), 5._default) call analysis_record_data (var_str ("h"), 7._default) call analysis_record_data (var_str ("h"), 7._default) call analysis_record_data (var_str ("h"), 7._default) call analysis_record_data (var_str ("h"), 7._default) call analysis_record_data (var_str ("h"), 9._default) call analysis_record_data (var_str ("h"), 9._default) call analysis_record_data (var_str ("h"), 9._default) call analysis_record_data (var_str ("h"), 9._default) call analysis_record_data (var_str ("h"), 9._default) call analysis_record_data (var_str ("h"), 9._default) call analysis_record_data (var_str ("h"), 9._default) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, '$out_file = "commands_23.dat"') call ifile_append (ifile, 'compile_analysis') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Delete Postscript output" write (u, "(A)") inquire (file = "commands_23.ps", exist = exist) if (exist) then u_file = free_unit () open (u_file, file = "commands_23.ps", action = "write", status = "old") close (u_file, status = "delete") end if inquire (file = "commands_23.ps", exist = exist) write (u, "(1x,A,L1)") "Postcript output exists = ", exist write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* TeX file" write (u, "(A)") inquire (file = "commands_23.tex", exist = exist) if (.not. exist) then write (u, "(A)") "ERROR: File commands_23.tex not found" return end if u_file = free_unit () open (u_file, file = "commands_23.tex", & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, *) inquire (file = "commands_23.ps", exist = exist) write (u, "(1x,A,L1)") "Postcript output exists = ", exist write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call analysis_final () call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_23" end subroutine commands_23 @ %def commands_23 @ \subsubsection{Histogram} Declare a histogram, fill it and display. <>= call test (commands_24, "commands_24", & "drawing options", & u, results) <>= public :: commands_24 <>= subroutine commands_24 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_24" write (u, "(A)") "* Purpose: check graph and drawing options" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, '$title = "Title"') call ifile_append (ifile, '$description = "Description"') call ifile_append (ifile, '$x_label = "X Label"') call ifile_append (ifile, '$y_label = "Y Label"') call ifile_append (ifile, 'graph_width_mm = 111') call ifile_append (ifile, 'graph_height_mm = 222') call ifile_append (ifile, 'x_min = -11') call ifile_append (ifile, 'x_max = 22') call ifile_append (ifile, 'y_min = -33') call ifile_append (ifile, 'y_max = 44') call ifile_append (ifile, '$gmlcode_bg = "GML Code BG"') call ifile_append (ifile, '$gmlcode_fg = "GML Code FG"') call ifile_append (ifile, '$fill_options = "Fill Options"') call ifile_append (ifile, '$draw_options = "Draw Options"') call ifile_append (ifile, '$err_options = "Error Options"') call ifile_append (ifile, '$symbol = "Symbol"') call ifile_append (ifile, 'histogram foo (0,1)') call ifile_append (ifile, 'plot bar') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Display analysis store" write (u, "(A)") call analysis_write (u, verbose=.true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call analysis_final () call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_24" end subroutine commands_24 @ %def commands_24 @ \subsubsection{Local Environment} Declare a local environment. <>= call test (commands_25, "commands_25", & "local process environment", & u, results) <>= public :: commands_25 <>= subroutine commands_25 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_25" write (u, "(A)") "* Purpose: declare local environment for process" write (u, "(A)") call syntax_model_file_init () call syntax_cmd_list_init () call global%global_init () call global%var_list%set_log (var_str ("?omega_openmp"), & .false., is_known = .true.) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'library = "commands_25_lib"') call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'process commands_25_p1 = g, g => g, g & &{ model = "QCD" }') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write_libraries (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_25" end subroutine commands_25 @ %def commands_25 @ \subsubsection{Alternative Setups} Declare a list of alternative setups. <>= call test (commands_26, "commands_26", & "alternative setups", & u, results) <>= public :: commands_26 <>= subroutine commands_26 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_26" write (u, "(A)") "* Purpose: declare alternative setups for simulation" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'int i = 0') call ifile_append (ifile, 'alt_setup = ({ i = 1 }, { i = 2 })') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write_expr (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_26" end subroutine commands_26 @ %def commands_26 @ \subsubsection{Unstable Particle} Define decay processes and declare a particle as unstable. Also check the commands stable, polarized, unpolarized. <>= call test (commands_27, "commands_27", & "unstable and polarized particles", & u, results) <>= public :: commands_27 <>= subroutine commands_27 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(prclib_entry_t), pointer :: lib write (u, "(A)") "* Test output: commands_27" write (u, "(A)") "* Purpose: modify particle properties" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call global%global_init () call global%var_list%set_string (var_str ("$method"), & var_str ("unit_test"), is_known=.true.) call global%var_list%set_string (var_str ("$phs_method"), & var_str ("single"), is_known=.true.) call global%var_list%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known=.true.) call global%var_list%set_log (var_str ("?vis_history"),& .false., is_known=.true.) call global%var_list%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) allocate (lib) call lib%init (var_str ("commands_27_lib")) call global%add_prclib (lib) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'ff = 0.4') call ifile_append (ifile, 'process d1 = s => f, fbar') call ifile_append (ifile, 'unstable s (d1)') call ifile_append (ifile, 'polarized f, fbar') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Show model" write (u, "(A)") call global%model%write (u) write (u, "(A)") write (u, "(A)") "* Extra Input" write (u, "(A)") call ifile_final (ifile) call ifile_append (ifile, '?diagonal_decay = true') call ifile_append (ifile, 'unstable s (d1)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%final () call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Show model" write (u, "(A)") call global%model%write (u) write (u, "(A)") write (u, "(A)") "* Extra Input" write (u, "(A)") call ifile_final (ifile) call ifile_append (ifile, '?isotropic_decay = true') call ifile_append (ifile, 'unstable s (d1)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%final () call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Show model" write (u, "(A)") call global%model%write (u) write (u, "(A)") write (u, "(A)") "* Extra Input" write (u, "(A)") call ifile_final (ifile) call ifile_append (ifile, 'stable s') call ifile_append (ifile, 'unpolarized f') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%final () call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Show model" write (u, "(A)") call global%model%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_model_file_init () call syntax_cmd_list_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_27" end subroutine commands_27 @ %def commands_27 @ \subsubsection{Quit the program} Quit the program. <>= call test (commands_28, "commands_28", & "quit", & u, results) <>= public :: commands_28 <>= subroutine commands_28 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root1, pn_root2 type(string_t), dimension(0) :: no_vars write (u, "(A)") "* Test output: commands_28" write (u, "(A)") "* Purpose: quit the program" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file: quit without code" write (u, "(A)") call ifile_append (ifile, 'quit') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root1, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root1, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write (u, vars = no_vars) write (u, "(A)") write (u, "(A)") "* Input file: quit with code" write (u, "(A)") call ifile_final (ifile) call command_list%final () call ifile_append (ifile, 'quit ( 3 + 4 )') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root2, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root2, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write (u, vars = no_vars) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_28" end subroutine commands_28 @ %def commands_28 @ \subsubsection{SLHA interface} Testing commands steering the SLHA interface. <>= call test (commands_29, "commands_29", & "SLHA interface", & u, results) <>= public :: commands_29 <>= subroutine commands_29 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(var_list_t), pointer :: model_vars type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_29" write (u, "(A)") "* Purpose: test SLHA interface" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call syntax_model_file_init () call syntax_slha_init () call global%global_init () write (u, "(A)") "* Model MSSM, read SLHA file" write (u, "(A)") call ifile_append (ifile, 'model = "MSSM"') call ifile_append (ifile, '?slha_read_decays = true') call ifile_append (ifile, 'read_slha ("sps1ap_decays.slha")') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Model MSSM, default values:" write (u, "(A)") call global%model%write (u, verbose = .false., & show_vertices = .false., show_particles = .false.) write (u, "(A)") write (u, "(A)") "* Selected global variables" write (u, "(A)") model_vars => global%model%get_var_list_ptr () call model_vars%write_var (var_str ("mch1"), u) call model_vars%write_var (var_str ("wch1"), u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") "* Model MSSM, values from SLHA file" write (u, "(A)") call global%model%write (u, verbose = .false., & show_vertices = .false., show_particles = .false.) write (u, "(A)") write (u, "(A)") "* Selected global variables" write (u, "(A)") model_vars => global%model%get_var_list_ptr () call model_vars%write_var (var_str ("mch1"), u) call model_vars%write_var (var_str ("wch1"), u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_slha_final () call syntax_model_file_final () call syntax_cmd_list_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_29" end subroutine commands_29 @ %def commands_29 @ \subsubsection{Expressions for scales} Declare a scale, factorization scale or factorization scale expression. <>= call test (commands_30, "commands_30", & "scales", & u, results) <>= public :: commands_30 <>= subroutine commands_30 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_30" write (u, "(A)") "* Purpose: define scales" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'scale = 200 GeV') call ifile_append (ifile, & 'factorization_scale = eval Pt [particle]') call ifile_append (ifile, & 'renormalization_scale = eval E [particle]') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write_expr (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_30" end subroutine commands_30 @ %def commands_30 @ \subsubsection{Weight and reweight expressions} Declare an expression for event weights and reweighting. <>= call test (commands_31, "commands_31", & "event weights/reweighting", & u, results) <>= public :: commands_31 <>= subroutine commands_31 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_31" write (u, "(A)") "* Purpose: define weight/reweight" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'weight = eval Pz [particle]') call ifile_append (ifile, 'reweight = eval M2 [particle]') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write_expr (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_31" end subroutine commands_31 @ %def commands_31 @ \subsubsection{Selecting events} Declare an expression for selecting events in an analysis. <>= call test (commands_32, "commands_32", & "event selection", & u, results) <>= public :: commands_32 <>= subroutine commands_32 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root write (u, "(A)") "* Test output: commands_32" write (u, "(A)") "* Purpose: define selection" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'selection = any PDG == 13 [particle]') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) call global%write_expr (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_32" end subroutine commands_32 @ %def commands_32 @ \subsubsection{Executing shell commands} Execute a shell command. <>= call test (commands_33, "commands_33", & "execute shell command", & u, results) <>= public :: commands_33 <>= subroutine commands_33 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root integer :: u_file, iostat character(3) :: buffer write (u, "(A)") "* Test output: commands_33" write (u, "(A)") "* Purpose: execute shell command" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'exec ("echo foo >> bar")') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root, u) write (u, "(A)") write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) u_file = free_unit () open (u_file, file = "bar", & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (iostat /= 0) exit end do write (u, "(A,A)") "should be 'foo': ", trim (buffer) close (u_file) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call command_list%final () call global%final () call syntax_cmd_list_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_33" end subroutine commands_33 @ %def commands_33 @ \subsubsection{Callback} Instead of an explicit write, use the callback feature to write the analysis file during event generation. We generate 4 events and arrange that the callback is executed while writing the 3rd event. <>= call test (commands_34, "commands_34", & "analysis via callback", & u, results) <>= public :: commands_34 <>= subroutine commands_34 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(command_list_t), target :: command_list type(rt_data_t), target :: global type(parse_node_t), pointer :: pn_root type(prclib_entry_t), pointer :: lib type(event_callback_34_t) :: event_callback write (u, "(A)") "* Test output: commands_34" write (u, "(A)") "* Purpose: write analysis data" write (u, "(A)") write (u, "(A)") "* Initialization: create observable" write (u, "(A)") call syntax_cmd_list_init () call global%global_init () call syntax_model_file_init () call global%global_init () call global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) call global%var_list%set_string (var_str ("$method"), & var_str ("unit_test"), is_known=.true.) call global%var_list%set_string (var_str ("$phs_method"), & var_str ("single"), is_known=.true.) call global%var_list%set_string (var_str ("$integration_method"),& var_str ("midpoint"), is_known=.true.) call global%var_list%set_real (var_str ("sqrts"), & 1000._default, is_known=.true.) call global%var_list%set_log (var_str ("?vis_history"),& .false., is_known=.true.) call global%var_list%set_log (var_str ("?integration_timer"),& .false., is_known = .true.) allocate (lib) call lib%init (var_str ("lib_cmd34")) call global%add_prclib (lib) write (u, "(A)") "* Prepare callback for writing analysis to I/O unit" write (u, "(A)") event_callback%u = u call global%set_event_callback (event_callback) write (u, "(A)") "* Input file" write (u, "(A)") call ifile_append (ifile, 'model = "Test"') call ifile_append (ifile, 'process commands_34_p = s, s => s, s') call ifile_append (ifile, 'compile') call ifile_append (ifile, 'iterations = 1:1000') call ifile_append (ifile, 'integrate (commands_34_p)') call ifile_append (ifile, 'observable sq') call ifile_append (ifile, 'analysis = record sq (sqrts)') call ifile_append (ifile, 'n_events = 4') call ifile_append (ifile, 'event_callback_interval = 3') call ifile_append (ifile, 'simulate (commands_34_p)') call ifile_write (ifile, u) write (u, "(A)") write (u, "(A)") "* Parse file" write (u, "(A)") call parse_ifile (ifile, pn_root) write (u, "(A)") "* Compile command list" write (u, "(A)") call command_list%compile (pn_root, global) call command_list%write (u) write (u, "(A)") write (u, "(A)") "* Execute command list" write (u, "(A)") call command_list%execute (global) write (u, "(A)") write (u, "(A)") "* Cleanup" call ifile_final (ifile) call analysis_final () call command_list%final () call global%final () call syntax_cmd_list_final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: commands_34" end subroutine commands_34 @ %def commands_34 @ For this test, we invent a callback object which simply writes the analysis file, using the standard call for this. Here we rely on the fact that the analysis data are stored as a global entity, otherwise we would have to access them via the event object. <>= type, extends (event_callback_t) :: event_callback_34_t private integer :: u = 0 contains procedure :: write => event_callback_34_write procedure :: proc => event_callback_34 end type event_callback_34_t @ %def event_callback_t @ The output routine is unused. The actual callback should write the analysis data to the output unit that we have injected into the callback object. <>= subroutine event_callback_34_write (event_callback, unit) class(event_callback_34_t), intent(in) :: event_callback integer, intent(in), optional :: unit end subroutine event_callback_34_write subroutine event_callback_34 (event_callback, i, event) class(event_callback_34_t), intent(in) :: event_callback integer(i64), intent(in) :: i class(generic_event_t), intent(in) :: event call analysis_write (event_callback%u) end subroutine event_callback_34 @ %def event_callback_34_write @ %def event_callback_34 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Toplevel module WHIZARD} <<[[whizard.f90]]>>= <> module whizard use io_units <> use system_defs, only: VERSION_STRING use system_defs, only: EOF, BACKSLASH use diagnostics use os_interface use ifiles use lexers use parser use eval_trees use models use phs_forests use prclib_stacks use slha_interface use blha_config use rt_data use commands <> <> <> save contains <> end module whizard @ %def whizard @ \subsection{Options} Here we introduce a wrapper that holds various user options, so they can transparently be passed from the main program to the [[whizard]] object. Most parameters are used for initializing the [[global]] state. <>= public :: whizard_options_t <>= type :: whizard_options_t type(string_t) :: job_id type(string_t), dimension(:), allocatable :: pack_args type(string_t), dimension(:), allocatable :: unpack_args type(string_t) :: preload_model type(string_t) :: default_lib type(string_t) :: preload_libraries logical :: rebuild_library = .false. logical :: recompile_library = .false. logical :: rebuild_user logical :: rebuild_phs = .false. logical :: rebuild_grids = .false. logical :: rebuild_events = .false. end type whizard_options_t @ %def whizard_options_t @ \subsection{Parse tree stack} We collect all parse trees that we generate in the [[whizard]] object. To this end, we create a stack of parse trees. They must not be finalized before the [[global]] object is finalized, because items such as a cut definition may contain references to the parse tree from which they were generated. <>= type, extends (parse_tree_t) :: pt_entry_t type(pt_entry_t), pointer :: previous => null () end type pt_entry_t @ %def pt_entry_t @ This is the stack. Since we always prepend, we just need the [[last]] pointer. <>= type :: pt_stack_t type(pt_entry_t), pointer :: last => null () contains <> end type pt_stack_t @ %def pt_stack_t @ The finalizer is called at the very end. <>= procedure :: final => pt_stack_final <>= subroutine pt_stack_final (pt_stack) class(pt_stack_t), intent(inout) :: pt_stack type(pt_entry_t), pointer :: current do while (associated (pt_stack%last)) current => pt_stack%last pt_stack%last => current%previous call parse_tree_final (current%parse_tree_t) deallocate (current) end do end subroutine pt_stack_final @ %def pt_stack_final @ Create and push a new entry, keeping the previous ones. <>= procedure :: push => pt_stack_push <>= subroutine pt_stack_push (pt_stack, parse_tree) class(pt_stack_t), intent(inout) :: pt_stack type(parse_tree_t), intent(out), pointer :: parse_tree type(pt_entry_t), pointer :: current allocate (current) parse_tree => current%parse_tree_t current%previous => pt_stack%last pt_stack%last => current end subroutine pt_stack_push @ %def pt_stack_push @ \subsection{The [[whizard]] object} An object of type [[whizard_t]] is the top-level wrapper for a \whizard\ instance. The object holds various default settings and the current state of the generator, the [[global]] object of type [[rt_data_t]]. This object contains, for instance, the list of variables and the process libraries. Since components of the [[global]] subobject are frequently used as targets, the [[whizard]] object should also consistently carry the [[target]] attribute. The various self-tests do no not use this object. They initialize only specific subsets of the system, according to their needs. Note: we intend to allow several concurrent instances. In the current implementation, there are still a few obstacles to this: the model library and the syntax tables are global variables, and the error handling uses global state. This should be improved. <>= public :: whizard_t <>= type :: whizard_t type(whizard_options_t) :: options type(rt_data_t) :: global type(pt_stack_t) :: pt_stack contains <> end type whizard_t @ %def whizard_t @ \subsection{Initialization and finalization} <>= procedure :: init => whizard_init <>= subroutine whizard_init (whizard, options, paths, logfile) class(whizard_t), intent(out), target :: whizard type(whizard_options_t), intent(in) :: options type(paths_t), intent(in), optional :: paths type(string_t), intent(in), optional :: logfile call init_syntax_tables () whizard%options = options call whizard%global%global_init (paths, logfile) call whizard%init_job_id () call whizard%init_rebuild_flags () call whizard%unpack_files () call whizard%preload_model () call whizard%preload_library () call whizard%global%init_fallback_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl")) end subroutine whizard_init @ %def whizard_init @ Apart from the global data which have been initialized above, the process and model lists need to be finalized. <>= procedure :: final => whizard_final <>= subroutine whizard_final (whizard) class(whizard_t), intent(inout), target :: whizard call whizard%global%final () call whizard%pt_stack%final () call whizard%pack_files () !!! JRR: WK please check (#529) ! call user_code_final () call final_syntax_tables () end subroutine whizard_final @ %def whizard_final @ Set the job ID, if nonempty. If the ID string is empty, the value remains undefined. <>= procedure :: init_job_id => whizard_init_job_id <>= subroutine whizard_init_job_id (whizard) class(whizard_t), intent(inout), target :: whizard associate (var_list => whizard%global%var_list, options => whizard%options) if (options%job_id /= "") then call var_list%set_string (var_str ("$job_id"), & options%job_id, is_known=.true.) end if end associate end subroutine whizard_init_job_id @ %def whizard_init_job_id @ Set the rebuild flags. They can be specified on the command line and set the initial value for the associated logical variables. <>= procedure :: init_rebuild_flags => whizard_init_rebuild_flags <>= subroutine whizard_init_rebuild_flags (whizard) class(whizard_t), intent(inout), target :: whizard associate (var_list => whizard%global%var_list, options => whizard%options) call var_list%append_log (var_str ("?rebuild_library"), & options%rebuild_library, intrinsic=.true.) call var_list%append_log (var_str ("?recompile_library"), & options%recompile_library, intrinsic=.true.) call var_list%append_log (var_str ("?rebuild_phase_space"), & options%rebuild_phs, intrinsic=.true.) call var_list%append_log (var_str ("?rebuild_grids"), & options%rebuild_grids, intrinsic=.true.) call var_list%append_log (var_str ("?powheg_rebuild_grids"), & options%rebuild_grids, intrinsic=.true.) call var_list%append_log (var_str ("?rebuild_events"), & options%rebuild_events, intrinsic=.true.) end associate end subroutine whizard_init_rebuild_flags @ %def whizard_init_rebuild_flags @ Pack/unpack files in the working directory, if requested. <>= procedure :: pack_files => whizard_pack_files procedure :: unpack_files => whizard_unpack_files <>= subroutine whizard_pack_files (whizard) class(whizard_t), intent(in), target :: whizard logical :: exist integer :: i type(string_t) :: file if (allocated (whizard%options%pack_args)) then do i = 1, size (whizard%options%pack_args) file = whizard%options%pack_args(i) call msg_message ("Packing file/dir '" // char (file) // "'") exist = os_file_exist (file) .or. os_dir_exist (file) if (exist) then call os_pack_file (whizard%options%pack_args(i), & whizard%global%os_data) else call msg_error ("File/dir '" // char (file) // "' not found") end if end do end if end subroutine whizard_pack_files subroutine whizard_unpack_files (whizard) class(whizard_t), intent(in), target :: whizard logical :: exist integer :: i type(string_t) :: file if (allocated (whizard%options%unpack_args)) then do i = 1, size (whizard%options%unpack_args) file = whizard%options%unpack_args(i) call msg_message ("Unpacking file '" // char (file) // "'") exist = os_file_exist (file) if (exist) then call os_unpack_file (whizard%options%unpack_args(i), & whizard%global%os_data) else call msg_error ("File '" // char (file) // "' not found") end if end do end if end subroutine whizard_unpack_files @ %def whizard_pack_files @ %def whizard_unpack_files @ This procedure preloads a model, if a model name is given. <>= procedure :: preload_model => whizard_preload_model <>= subroutine whizard_preload_model (whizard) class(whizard_t), intent(inout), target :: whizard type(string_t) :: model_name model_name = whizard%options%preload_model if (model_name /= "") then call whizard%global%read_model (model_name, whizard%global%preload_model) whizard%global%model => whizard%global%preload_model if (associated (whizard%global%model)) then call whizard%global%model%link_var_list (whizard%global%var_list) call msg_message ("Preloaded model: " & // char (model_name)) else call msg_fatal ("Preloading model " // char (model_name) & // " failed") end if else call msg_message ("No model preloaded") end if end subroutine whizard_preload_model @ %def whizard_preload_model @ This procedure preloads a library, if a library name is given. Note: This version just opens a new library with that name. It does not load (yet) an existing library on file, as previous \whizard\ versions would do. <>= procedure :: preload_library => whizard_preload_library <>= subroutine whizard_preload_library (whizard) class(whizard_t), intent(inout), target :: whizard type(string_t) :: library_name, libs type(string_t), dimension(:), allocatable :: libname_static type(prclib_entry_t), pointer :: lib_entry integer :: i call get_prclib_static (libname_static) do i = 1, size (libname_static) allocate (lib_entry) call lib_entry%init_static (libname_static(i)) call whizard%global%add_prclib (lib_entry) end do libs = adjustl (whizard%options%preload_libraries) if (libs == "" .and. whizard%options%default_lib /= "") then allocate (lib_entry) call lib_entry%init (whizard%options%default_lib) call whizard%global%add_prclib (lib_entry) call msg_message ("Preloaded library: " // & char (whizard%options%default_lib)) end if SCAN_LIBS: do while (libs /= "") call split (libs, library_name, " ") if (library_name /= "") then allocate (lib_entry) call lib_entry%init (library_name) call whizard%global%add_prclib (lib_entry) call msg_message ("Preloaded library: " // char (library_name)) end if end do SCAN_LIBS end subroutine whizard_preload_library @ %def whizard_preload_library @ \subsection{Initialization and finalization (old version)} These procedures initialize and finalize global variables. Most of them are collected in the [[global]] data record located here, the others are syntax tables located in various modules, which do not change during program execution. Furthermore, there is a global model list and a global process store, which get filled during program execution but are finalized here. During initialization, we can preload a default model and initialize a default library for setting up processes. The default library is loaded if requested by the setup. Further libraries can be loaded as specified by command-line flags. @ Initialize/finalize the syntax tables used by WHIZARD: <>= public :: init_syntax_tables public :: final_syntax_tables <>= subroutine init_syntax_tables () call syntax_model_file_init () call syntax_phs_forest_init () call syntax_pexpr_init () call syntax_slha_init () call syntax_cmd_list_init () end subroutine init_syntax_tables subroutine final_syntax_tables () call syntax_model_file_final () call syntax_phs_forest_final () call syntax_pexpr_final () call syntax_slha_final () call syntax_cmd_list_final () end subroutine final_syntax_tables @ %def init_syntax_tables @ %def final_syntax_tables @ Write the syntax tables to external files. <>= public :: write_syntax_tables <>= subroutine write_syntax_tables () integer :: unit character(*), parameter :: file_model = "whizard.model_file.syntax" character(*), parameter :: file_phs = "whizard.phase_space_file.syntax" character(*), parameter :: file_pexpr = "whizard.prt_expressions.syntax" character(*), parameter :: file_slha = "whizard.slha.syntax" character(*), parameter :: file_sindarin = "whizard.sindarin.syntax" unit = free_unit () print *, "Writing file '" // file_model // "'" open (unit=unit, file=file_model, status="replace", action="write") write (unit, "(A)") VERSION_STRING write (unit, "(A)") "Syntax definition file: " // file_model call syntax_model_file_write (unit) close (unit) print *, "Writing file '" // file_phs // "'" open (unit=unit, file=file_phs, status="replace", action="write") write (unit, "(A)") VERSION_STRING write (unit, "(A)") "Syntax definition file: " // file_phs call syntax_phs_forest_write (unit) close (unit) print *, "Writing file '" // file_pexpr // "'" open (unit=unit, file=file_pexpr, status="replace", action="write") write (unit, "(A)") VERSION_STRING write (unit, "(A)") "Syntax definition file: " // file_pexpr call syntax_pexpr_write (unit) close (unit) print *, "Writing file '" // file_slha // "'" open (unit=unit, file=file_slha, status="replace", action="write") write (unit, "(A)") VERSION_STRING write (unit, "(A)") "Syntax definition file: " // file_slha call syntax_slha_write (unit) close (unit) print *, "Writing file '" // file_sindarin // "'" open (unit=unit, file=file_sindarin, status="replace", action="write") write (unit, "(A)") VERSION_STRING write (unit, "(A)") "Syntax definition file: " // file_sindarin call syntax_cmd_list_write (unit) close (unit) end subroutine write_syntax_tables @ %def write_syntax_tables @ \subsection{Execute command lists} Process commands given on the command line, stored as an [[ifile]]. The whole input is read, compiled and executed as a whole. <>= procedure :: process_ifile => whizard_process_ifile <>= subroutine whizard_process_ifile (whizard, ifile, quit, quit_code) class(whizard_t), intent(inout), target :: whizard type(ifile_t), intent(in) :: ifile logical, intent(out) :: quit integer, intent(out) :: quit_code type(lexer_t), target :: lexer type(stream_t), target :: stream call msg_message ("Reading commands given on the command line") call lexer_init_cmd_list (lexer) call stream_init (stream, ifile) call whizard%process_stream (stream, lexer, quit, quit_code) call stream_final (stream) call lexer_final (lexer) end subroutine whizard_process_ifile @ %def whizard_process_ifile @ Process standard input as a command list. The whole input is read, compiled and executed as a whole. <>= procedure :: process_stdin => whizard_process_stdin <>= subroutine whizard_process_stdin (whizard, quit, quit_code) class(whizard_t), intent(inout), target :: whizard logical, intent(out) :: quit integer, intent(out) :: quit_code type(lexer_t), target :: lexer type(stream_t), target :: stream call msg_message ("Reading commands from standard input") call lexer_init_cmd_list (lexer) call stream_init (stream, 5) call whizard%process_stream (stream, lexer, quit, quit_code) call stream_final (stream) call lexer_final (lexer) end subroutine whizard_process_stdin @ %def whizard_process_stdin @ Process a file as a command list. <>= procedure :: process_file => whizard_process_file <>= subroutine whizard_process_file (whizard, file, quit, quit_code) class(whizard_t), intent(inout), target :: whizard type(string_t), intent(in) :: file logical, intent(out) :: quit integer, intent(out) :: quit_code type(lexer_t), target :: lexer type(stream_t), target :: stream logical :: exist call msg_message ("Reading commands from file '" // char (file) // "'") inquire (file=char(file), exist=exist) if (exist) then call lexer_init_cmd_list (lexer) call stream_init (stream, char (file)) call whizard%process_stream (stream, lexer, quit, quit_code) call stream_final (stream) call lexer_final (lexer) else call msg_error ("File '" // char (file) // "' not found") end if end subroutine whizard_process_file @ %def whizard_process_file @ <>= procedure :: process_stream => whizard_process_stream <>= subroutine whizard_process_stream (whizard, stream, lexer, quit, quit_code) class(whizard_t), intent(inout), target :: whizard type(stream_t), intent(inout), target :: stream type(lexer_t), intent(inout), target :: lexer logical, intent(out) :: quit integer, intent(out) :: quit_code type(parse_tree_t), pointer :: parse_tree type(command_list_t), target :: command_list call lexer_assign_stream (lexer, stream) call whizard%pt_stack%push (parse_tree) call parse_tree_init (parse_tree, syntax_cmd_list, lexer) if (associated (parse_tree%get_root_ptr ())) then whizard%global%lexer => lexer call command_list%compile (parse_tree%get_root_ptr (), & whizard%global) end if call whizard%global%activate () call command_list%execute (whizard%global) call command_list%final () quit = whizard%global%quit quit_code = whizard%global%quit_code end subroutine whizard_process_stream @ %def whizard_process_stream @ \subsection{The WHIZARD shell} This procedure implements interactive mode. One line is processed at a time. <>= procedure :: shell => whizard_shell <>= subroutine whizard_shell (whizard, quit_code) class(whizard_t), intent(inout), target :: whizard integer, intent(out) :: quit_code type(lexer_t), target :: lexer type(stream_t), target :: stream type(string_t) :: prompt1 type(string_t) :: prompt2 type(string_t) :: input type(string_t) :: extra integer :: last integer :: iostat logical :: mask_tmp logical :: quit call msg_message ("Launching interactive shell") call lexer_init_cmd_list (lexer) prompt1 = "whish? " prompt2 = " > " COMMAND_LOOP: do call put (6, prompt1) call get (5, input, iostat=iostat) if (iostat > 0 .or. iostat == EOF) exit COMMAND_LOOP CONTINUE_INPUT: do last = len_trim (input) if (extract (input, last, last) /= BACKSLASH) exit CONTINUE_INPUT call put (6, prompt2) call get (5, extra, iostat=iostat) if (iostat > 0) exit COMMAND_LOOP input = replace (input, last, extra) end do CONTINUE_INPUT call stream_init (stream, input) mask_tmp = mask_fatal_errors mask_fatal_errors = .true. call whizard%process_stream (stream, lexer, quit, quit_code) msg_count = 0 mask_fatal_errors = mask_tmp call stream_final (stream) if (quit) exit COMMAND_LOOP end do COMMAND_LOOP print * call lexer_final (lexer) end subroutine whizard_shell @ %def whizard_shell @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Tools for the command line} We don't intent to be very smart here, but this module provides a few small tools that simplify dealing with the command line. <<[[cmdline_options.f90]]>>= <> module cmdline_options <> use diagnostics <> public :: init_options public :: no_option_value public :: get_option_value <> abstract interface subroutine msg end subroutine msg end interface procedure (msg), pointer :: print_usage => null () contains subroutine init_options (usage_msg) procedure (msg) :: usage_msg print_usage => usage_msg end subroutine init_options subroutine no_option_value (option, value) type(string_t), intent(in) :: option, value if (value /= "") then call msg_error (" Option '" // char (option) // "' should have no value") end if end subroutine no_option_value function get_option_value (i, option, value) result (string) type(string_t) :: string integer, intent(inout) :: i type(string_t), intent(in) :: option type(string_t), intent(in), optional :: value character(CMDLINE_ARG_LEN) :: arg_value integer :: arg_len, arg_status logical :: has_value if (present (value)) then has_value = value /= "" else has_value = .false. end if if (has_value) then string = value else i = i + 1 call get_command_argument (i, arg_value, arg_len, arg_status) select case (arg_status) case (0) case (-1) call msg_error (" Option value truncated: '" // arg_value // "'") case default call print_usage () call msg_fatal (" Option '" // char (option) // "' needs a value") end select select case (arg_value(1:1)) case ("-") call print_usage () call msg_fatal (" Option '" // char (option) // "' needs a value") end select string = trim (arg_value) end if end function get_option_value end module cmdline_options @ %def init_options @ %def no_option_value @ %def get_option_value @ %def cmdline_options @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Query Feature Support} This module accesses the various optional features (modules) that WHIZARD can support and repors on their availability. <<[[features.f90]]>>= module features use string_utils, only: lower_case use system_dependencies, only: WHIZARD_VERSION <> <> <> contains <> end module features @ %def features @ \subsection{Output} <>= public :: print_features <>= subroutine print_features () print "(A)", "WHIZARD " // WHIZARD_VERSION print "(A)", "Build configuration:" <> print "(A)", "Optional features available in this build:" <> end subroutine print_features @ %def print_features @ \subsection{Query function} <>= subroutine check (feature, recognized, result, help) character(*), intent(in) :: feature logical, intent(out) :: recognized character(*), intent(out) :: result, help recognized = .true. result = "no" select case (lower_case (trim (feature))) <> case default recognized = .false. end select end subroutine check @ %def check @ Print this result: <>= subroutine print_check (feature) character(*), intent(in) :: feature character(16) :: f logical :: recognized character(10) :: result character(48) :: help call check (feature, recognized, result, help) if (.not. recognized) then result = "unknown" help = "" end if f = feature print "(2x,A,1x,A,'(',A,')')", f, result, trim (help) end subroutine print_check @ %def print_check @ \subsection{Basic configuration} <>= call print_check ("precision") <>= use kinds, only: default <>= case ("precision") write (result, "(I0)") precision (1._default) help = "significant decimals of real/complex numbers" @ \subsection{Optional features case by case} <>= call print_check ("OpenMP") <>= use system_dependencies, only: openmp_is_active <>= case ("openmp") if (openmp_is_active ()) then result = "yes" end if help = "OpenMP parallel execution" @ <>= call print_check ("GoSam") <>= use system_dependencies, only: GOSAM_AVAILABLE <>= case ("gosam") if (GOSAM_AVAILABLE) then result = "yes" end if help = "external NLO matrix element provider" @ <>= call print_check ("OpenLoops") <>= use system_dependencies, only: OPENLOOPS_AVAILABLE <>= case ("openloops") if (OPENLOOPS_AVAILABLE) then result = "yes" end if help = "external NLO matrix element provider" @ <>= call print_check ("Recola") <>= use system_dependencies, only: RECOLA_AVAILABLE <>= case ("recola") if (RECOLA_AVAILABLE) then result = "yes" end if help = "external NLO matrix element provider" @ <>= call print_check ("LHAPDF") <>= use system_dependencies, only: LHAPDF5_AVAILABLE use system_dependencies, only: LHAPDF6_AVAILABLE <>= case ("lhapdf") if (LHAPDF5_AVAILABLE) then result = "v5" else if (LHAPDF6_AVAILABLE) then result = "v6" end if help = "PDF library" @ <>= call print_check ("HOPPET") <>= use system_dependencies, only: HOPPET_AVAILABLE <>= case ("hoppet") if (HOPPET_AVAILABLE) then result = "yes" end if help = "PDF evolution package" @ <>= call print_check ("fastjet") <>= use jets, only: fastjet_available <>= case ("fastjet") if (fastjet_available ()) then result = "yes" end if help = "jet-clustering package" @ <>= call print_check ("Pythia6") <>= use system_dependencies, only: PYTHIA6_AVAILABLE <>= case ("pythia6") if (PYTHIA6_AVAILABLE) then result = "yes" end if help = "direct access for shower/hadronization" @ <>= call print_check ("Pythia8") <>= use system_dependencies, only: PYTHIA8_AVAILABLE <>= case ("pythia8") if (PYTHIA8_AVAILABLE) then result = "yes" end if help = "direct access for shower/hadronization" @ <>= call print_check ("StdHEP") <>= case ("stdhep") result = "yes" help = "event I/O format" @ <>= call print_check ("HepMC") <>= use hepmc_interface, only: hepmc_is_available <>= case ("hepmc") if (hepmc_is_available ()) then result = "yes" end if help = "event I/O format" @ <>= call print_check ("LCIO") <>= use lcio_interface, only: lcio_is_available <>= case ("lcio") if (lcio_is_available ()) then result = "yes" end if help = "event I/O format" @ <>= call print_check ("MetaPost") <>= use system_dependencies, only: EVENT_ANALYSIS <>= case ("metapost") result = EVENT_ANALYSIS help = "graphical event analysis via LaTeX/MetaPost" @ @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Driver program} The main program handles command options, initializes the environment, and runs WHIZARD in a particular mode (interactive, file, standard input). This is also used in the C interface: <>= integer, parameter :: CMDLINE_ARG_LEN = 1000 @ %def CMDLINE_ARG_LEN @ The actual main program: <<[[main.f90]]>>= <> program main <> use system_dependencies use diagnostics use ifiles use os_interface use rt_data, only: show_description_of_string, show_tex_descriptions use whizard use cmdline_options use features <> implicit none <> !!! (WK 02/2016) Interface for the separate external routine below interface subroutine print_usage () end subroutine print_usage end interface ! Main program variable declarations character(CMDLINE_ARG_LEN) :: arg character(2) :: option type(string_t) :: long_option, value integer :: i, j, arg_len, arg_status logical :: look_for_options logical :: interactive logical :: banner type(string_t) :: job_id, files, this, model, default_lib, library, libraries type(string_t) :: logfile, query_string logical :: user_code_enable = .false. integer :: n_user_src = 0, n_user_lib = 0 type(string_t) :: user_src, user_lib, user_target type(paths_t) :: paths type(string_t) :: pack_arg, unpack_arg type(string_t), dimension(:), allocatable :: pack_args, unpack_args type(string_t), dimension(:), allocatable :: tmp_strings logical :: rebuild_library, rebuild_user logical :: rebuild_phs, rebuild_grids, rebuild_events logical :: recompile_library type(ifile_t) :: commands type(string_t) :: command type(whizard_options_t), allocatable :: options type(whizard_t), allocatable, target :: whizard_instance ! Exit status logical :: quit = .false. integer :: quit_code = 0 ! Initial values look_for_options = .true. interactive = .false. job_id = "" files = "" model = "SM" default_lib = "default_lib" library = "" libraries = "" banner = .true. logging = .true. msg_level = RESULT logfile = "whizard.log" user_src = "" user_lib = "" user_target = "" rebuild_library = .false. rebuild_user = .false. rebuild_phs = .false. rebuild_grids = .false. rebuild_events = .false. recompile_library = .false. call paths_init (paths) <> ! Read and process options call init_options (print_usage) i = 0 SCAN_CMDLINE: do i = i + 1 call get_command_argument (i, arg, arg_len, arg_status) select case (arg_status) case (0) case (-1) call msg_error (" Command argument truncated: '" // arg // "'") case default exit SCAN_CMDLINE end select if (look_for_options) then select case (arg(1:2)) case ("--") value = trim (arg) call split (value, long_option, "=") select case (char (long_option)) case ("--version") call no_option_value (long_option, value) call print_version (); stop case ("--help") call no_option_value (long_option, value) call print_usage (); stop case ("--prefix") paths%prefix = get_option_value (i, long_option, value) cycle scan_cmdline case ("--exec-prefix") paths%exec_prefix = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--bindir") paths%bindir = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--libdir") paths%libdir = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--includedir") paths%includedir = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--datarootdir") paths%datarootdir = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--libtool") paths%libtool = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--lhapdfdir") paths%lhapdfdir = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--check") call print_usage () call msg_fatal ("Option --check not supported & &(for unit tests, run whizard_ut instead)") case ("--show-config") call no_option_value (long_option, value) call print_features (); stop case ("--execute") command = get_option_value (i, long_option, value) call ifile_append (commands, command) cycle SCAN_CMDLINE case ("--interactive") call no_option_value (long_option, value) interactive = .true. cycle SCAN_CMDLINE case ("--job-id") job_id = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--library") library = get_option_value (i, long_option, value) libraries = libraries // " " // library cycle SCAN_CMDLINE case ("--no-library") call no_option_value (long_option, value) default_lib = "" library = "" libraries = "" cycle SCAN_CMDLINE case ("--localprefix") paths%localprefix = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--logfile") logfile = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--no-logfile") call no_option_value (long_option, value) logfile = "" cycle SCAN_CMDLINE case ("--logging") call no_option_value (long_option, value) logging = .true. cycle SCAN_CMDLINE case ("--no-logging") call no_option_value (long_option, value) logging = .false. cycle SCAN_CMDLINE case ("--query") call no_option_value (long_option, value) query_string = get_option_value (i, long_option, value) call show_description_of_string (query_string) call exit (0) case ("--generate-variables-tex") call no_option_value (long_option, value) call show_tex_descriptions () call exit (0) case ("--debug") call no_option_value (long_option, value) call set_debug_levels (get_option_value (i, long_option, value)) cycle SCAN_CMDLINE case ("--debug2") call no_option_value (long_option, value) call set_debug2_levels (get_option_value (i, long_option, value)) cycle SCAN_CMDLINE case ("--single-event") call no_option_value (long_option, value) single_event = .true. cycle SCAN_CMDLINE case ("--banner") call no_option_value (long_option, value) banner = .true. cycle SCAN_CMDLINE case ("--no-banner") call no_option_value (long_option, value) banner = .false. cycle SCAN_CMDLINE case ("--pack") pack_arg = get_option_value (i, long_option, value) if (allocated (pack_args)) then call move_alloc (from=pack_args, to=tmp_strings) allocate (pack_args (size (tmp_strings)+1)) pack_args(1:size(tmp_strings)) = tmp_strings else allocate (pack_args (1)) end if pack_args(size(pack_args)) = pack_arg cycle SCAN_CMDLINE case ("--unpack") unpack_arg = get_option_value (i, long_option, value) if (allocated (unpack_args)) then call move_alloc (from=unpack_args, to=tmp_strings) allocate (unpack_args (size (tmp_strings)+1)) unpack_args(1:size(tmp_strings)) = tmp_strings else allocate (unpack_args (1)) end if unpack_args(size(unpack_args)) = unpack_arg cycle SCAN_CMDLINE case ("--model") model = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--no-model") call no_option_value (long_option, value) model = "" cycle SCAN_CMDLINE case ("--rebuild") call no_option_value (long_option, value) rebuild_library = .true. rebuild_user = .true. rebuild_phs = .true. rebuild_grids = .true. rebuild_events = .true. cycle SCAN_CMDLINE case ("--no-rebuild") call no_option_value (long_option, value) rebuild_library = .false. recompile_library = .false. rebuild_user = .false. rebuild_phs = .false. rebuild_grids = .false. rebuild_events = .false. cycle SCAN_CMDLINE case ("--rebuild-library") call no_option_value (long_option, value) rebuild_library = .true. cycle SCAN_CMDLINE case ("--rebuild-user") call no_option_value (long_option, value) rebuild_user = .true. cycle SCAN_CMDLINE case ("--rebuild-phase-space") call no_option_value (long_option, value) rebuild_phs = .true. cycle SCAN_CMDLINE case ("--rebuild-grids") call no_option_value (long_option, value) rebuild_grids = .true. cycle SCAN_CMDLINE case ("--rebuild-events") call no_option_value (long_option, value) rebuild_events = .true. cycle SCAN_CMDLINE case ("--recompile") call no_option_value (long_option, value) recompile_library = .true. rebuild_grids = .true. cycle SCAN_CMDLINE case ("--user") user_code_enable = .true. cycle SCAN_CMDLINE case ("--user-src") if (user_src == "") then user_src = get_option_value (i, long_option, value) else user_src = user_src // " " & // get_option_value (i, long_option, value) end if n_user_src = n_user_src + 1 cycle SCAN_CMDLINE case ("--user-lib") if (user_lib == "") then user_lib = get_option_value (i, long_option, value) else user_lib = user_lib // " " & // get_option_value (i, long_option, value) end if n_user_lib = n_user_lib + 1 cycle SCAN_CMDLINE case ("--user-target") user_target = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--write-syntax-tables") call no_option_value (long_option, value) call init_syntax_tables () call write_syntax_tables () call final_syntax_tables () stop cycle SCAN_CMDLINE case default call print_usage () call msg_fatal ("Option '" // trim (arg) // "' not recognized") end select end select select case (arg(1:1)) case ("-") j = 1 if (len_trim (arg) == 1) then look_for_options = .false. else SCAN_SHORT_OPTIONS: do j = j + 1 if (j > len_trim (arg)) exit SCAN_SHORT_OPTIONS option = "-" // arg(j:j) select case (option) case ("-V") call print_version (); stop case ("-?", "-h") call print_usage (); stop case ("-e") command = get_option_value (i, var_str (option)) call ifile_append (commands, command) cycle SCAN_CMDLINE case ("-i") interactive = .true. cycle SCAN_SHORT_OPTIONS case ("-J") if (j == len_trim (arg)) then job_id = get_option_value (i, var_str (option)) else job_id = trim (arg(j+1:)) end if cycle SCAN_CMDLINE case ("-l") if (j == len_trim (arg)) then library = get_option_value (i, var_str (option)) else library = trim (arg(j+1:)) end if libraries = libraries // " " // library cycle SCAN_CMDLINE case ("-L") if (j == len_trim (arg)) then logfile = get_option_value (i, var_str (option)) else logfile = trim (arg(j+1:)) end if cycle SCAN_CMDLINE case ("-m") if (j < len_trim (arg)) call msg_fatal & ("Option '" // option // "' needs a value") model = get_option_value (i, var_str (option)) cycle SCAN_CMDLINE case ("-q") call no_option_value (long_option, value) query_string = get_option_value (i, long_option, value) call show_description_of_string (query_string) call exit (0) case ("-r") rebuild_library = .true. rebuild_user = .true. rebuild_phs = .true. rebuild_grids = .true. rebuild_events = .true. cycle SCAN_SHORT_OPTIONS case ("-u") user_code_enable = .true. cycle SCAN_SHORT_OPTIONS case default call print_usage () call msg_fatal & ("Option '" // option // "' not recognized") end select end do SCAN_SHORT_OPTIONS end if case default files = files // " " // trim (arg) end select else files = files // " " // trim (arg) end if end do SCAN_CMDLINE ! Overall initialization if (logfile /= "") call logfile_init (logfile) if (banner) call msg_banner () allocate (options) allocate (whizard_instance) if (.not. quit) then ! Set options and initialize the whizard object options%job_id = job_id if (allocated (pack_args)) then options%pack_args = pack_args else allocate (options%pack_args (0)) end if if (allocated (unpack_args)) then options%unpack_args = unpack_args else allocate (options%unpack_args (0)) end if options%preload_model = model options%default_lib = default_lib options%preload_libraries = libraries options%rebuild_library = rebuild_library options%recompile_library = recompile_library options%rebuild_user = rebuild_user options%rebuild_phs = rebuild_phs options%rebuild_grids = rebuild_grids options%rebuild_events = rebuild_events <> call whizard_instance%init (options, paths, logfile) call mask_term_signals () end if ! Run commands given on the command line if (.not. quit .and. ifile_get_length (commands) > 0) then call whizard_instance%process_ifile (commands, quit, quit_code) end if if (.not. quit) then ! Process commands from standard input if (.not. interactive .and. files == "") then call whizard_instance%process_stdin (quit, quit_code) ! ... or process commands from file else files = trim (adjustl (files)) SCAN_FILES: do while (files /= "") call split (files, this, " ") call whizard_instance%process_file (this, quit, quit_code) if (quit) exit SCAN_FILES end do SCAN_FILES end if end if ! Enter an interactive shell if requested if (.not. quit .and. interactive) then call whizard_instance%shell (quit_code) end if ! Overall finalization call ifile_final (commands) deallocate (options) call whizard_instance%final () deallocate (whizard_instance) <> call terminate_now_if_signal () call release_term_signals () call msg_terminate (quit_code = quit_code) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! contains subroutine print_version () print "(A)", "WHIZARD " // WHIZARD_VERSION print "(A)", "Copyright (C) 1999-2018 Wolfgang Kilian, Thorsten Ohl, Juergen Reuter" print "(A)", " --------------------------------------- " print "(A)", "This is free software; see the source for copying conditions. There is NO" print "(A)", "warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." print * end subroutine print_version end program main !!! (WK 02/2016) !!! Separate subroutine, because this becomes a procedure pointer target !!! Internal procedures as targets are not supported by some compilers. subroutine print_usage () use system_dependencies, only: WHIZARD_VERSION print "(A)", "WHIZARD " // WHIZARD_VERSION print "(A)", "Usage: whizard [OPTIONS] [FILE]" print "(A)", "Run WHIZARD with the command list taken from FILE(s)" print "(A)", "Options for resetting default directories and tools" & // "(GNU naming conventions):" print "(A)", " --prefix DIR" print "(A)", " --exec-prefix DIR" print "(A)", " --bindir DIR" print "(A)", " --libdir DIR" print "(A)", " --includedir DIR" print "(A)", " --datarootdir DIR" print "(A)", " --libtool LOCAL_LIBTOOL" print "(A)", " --lhapdfdir DIR (PDF sets directory)" print "(A)", "Other options:" print "(A)", "-h, --help display this help and exit" print "(A)", " --banner display banner at startup (default)" print "(A)", " --debug AREA switch on debug output for AREA." print "(A)", " AREA can be one of Whizard's src dirs or 'all'" print "(A)", " --debug2 AREA switch on more verbose debug output for AREA." print "(A)", " --single-event only compute one phase-space point (for debugging)" print "(A)", "-e, --execute CMDS execute SINDARIN CMDS before reading FILE(s)" print "(A)", "-i, --interactive run interactively after reading FILE(s)" print "(A)", "-J, --job-id STRING set job ID to STRING (default: empty)" print "(A)", "-l, --library LIB preload process library NAME" print "(A)", " --localprefix DIR" print "(A)", " search in DIR for local models (default: ~/.whizard)" print "(A)", "-L, --logfile FILE write log to FILE (default: 'whizard.log'" print "(A)", " --logging switch on logging at startup (default)" print "(A)", "-m, --model NAME preload model NAME (default: 'SM')" print "(A)", " --no-banner do not display banner at startup" print "(A)", " --no-library do not preload process library" print "(A)", " --no-logfile do not write a logfile" print "(A)", " --no-logging switch off logging at startup" print "(A)", " --no-model do not preload a model" print "(A)", " --no-rebuild do not force rebuilding" print "(A)", " --pack DIR tar/gzip DIR after job" print "(A)", "-q, --query VARIABLE display documentation of VARIABLE" print "(A)", "-r, --rebuild rebuild all (see below)" print "(A)", " --rebuild-library" print "(A)", " rebuild process code library" print "(A)", " --rebuild-user rebuild user-provided code" print "(A)", " --rebuild-phase-space" print "(A)", " rebuild phase-space configuration" print "(A)", " --rebuild-grids rebuild integration grids" print "(A)", " --rebuild-events rebuild event samples" print "(A)", " --recompile recompile process code" print "(A)", " --show-config show build-time configuration" print "(A)", " --unpack FILE untar/gunzip FILE before job" print "(A)", "-u --user enable user-provided code" print "(A)", " --user-src FILE user-provided source file" print "(A)", " --user-lib FILE user-provided library file" print "(A)", " --user-target BN basename of created user library (default: user)" print "(A)", "-V, --version output version information and exit" print "(A)", " --write-syntax-tables" print "(A)", " write the internal syntax tables to files and exit" print "(A)", "- further options are taken as filenames" print * print "(A)", "With no FILE, read standard input." end subroutine print_usage @ %def main @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Driver program for the unit tests} This is a variant of the above main program that takes unit-test names as command-line options and runs those tests. <<[[main_ut.f90]]>>= <> program main_ut <> use unit_tests use io_units use system_dependencies use diagnostics use os_interface use cmdline_options use model_testbed !NODEP! <> <> implicit none <> !!! (WK 02/2016) Interface for the separate external routine below interface subroutine print_usage () end subroutine print_usage end interface ! Main program variable declarations character(CMDLINE_ARG_LEN) :: arg character(2) :: option type(string_t) :: long_option, value integer :: i, j, arg_len, arg_status logical :: look_for_options logical :: banner type(string_t) :: check, checks type(test_results_t) :: test_results logical :: success ! Exit status integer :: quit_code = 0 ! Initial values look_for_options = .true. banner = .true. logging = .false. msg_level = RESULT check = "" checks = "" <> ! Read and process options call init_options (print_usage) i = 0 SCAN_CMDLINE: do i = i + 1 call get_command_argument (i, arg, arg_len, arg_status) select case (arg_status) case (0) case (-1) call msg_error (" Command argument truncated: '" // arg // "'") case default exit SCAN_CMDLINE end select if (look_for_options) then select case (arg(1:2)) case ("--") value = trim (arg) call split (value, long_option, "=") select case (char (long_option)) case ("--version") call no_option_value (long_option, value) call print_version (); stop case ("--help") call no_option_value (long_option, value) call print_usage (); stop case ("--banner") call no_option_value (long_option, value) banner = .true. cycle SCAN_CMDLINE case ("--no-banner") call no_option_value (long_option, value) banner = .false. cycle SCAN_CMDLINE case ("--check") check = get_option_value (i, long_option, value) checks = checks // " " // check cycle SCAN_CMDLINE case ("--debug") call no_option_value (long_option, value) call set_debug_levels (get_option_value (i, long_option, value)) cycle SCAN_CMDLINE case ("--debug2") call no_option_value (long_option, value) call set_debug2_levels (get_option_value (i, long_option, value)) cycle SCAN_CMDLINE case default call print_usage () call msg_fatal ("Option '" // trim (arg) // "' not recognized") end select end select select case (arg(1:1)) case ("-") j = 1 if (len_trim (arg) == 1) then look_for_options = .false. else SCAN_SHORT_OPTIONS: do j = j + 1 if (j > len_trim (arg)) exit SCAN_SHORT_OPTIONS option = "-" // arg(j:j) select case (option) case ("-V") call print_version (); stop case ("-?", "-h") call print_usage (); stop case default call print_usage () call msg_fatal & ("Option '" // option // "' not recognized") end select end do SCAN_SHORT_OPTIONS end if case default call print_usage () call msg_fatal ("Option '" // trim (arg) // "' not recognized") end select else call print_usage () call msg_fatal ("Option '" // trim (arg) // "' not recognized") end if end do SCAN_CMDLINE ! Overall initialization if (banner) call msg_banner () ! Run any self-checks (and no commands) if (checks /= "") then checks = trim (adjustl (checks)) RUN_CHECKS: do while (checks /= "") call split (checks, check, " ") call whizard_check (check, test_results) end do RUN_CHECKS call test_results%wrapup (6, success) if (.not. success) quit_code = 7 end if <> call msg_terminate (quit_code = quit_code) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! contains subroutine print_version () print "(A)", "WHIZARD " // WHIZARD_VERSION // " (unit test driver)" print "(A)", "Copyright (C) 1999-2018 Wolfgang Kilian, Thorsten Ohl, Juergen Reuter" print "(A)", " --------------------------------------- " print "(A)", "This is free software; see the source for copying conditions. There is NO" print "(A)", "warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." print * end subroutine print_version <> end program main_ut !!! (WK 02/2016) !!! Separate subroutine, because this becomes a procedure pointer target !!! Internal procedures as targets are not supported by some compilers. subroutine print_usage () use system_dependencies, only: WHIZARD_VERSION print "(A)", "WHIZARD " // WHIZARD_VERSION // " (unit test driver)" print "(A)", "Usage: whizard_ut [OPTIONS] [FILE]" print "(A)", "Run WHIZARD unit tests as given on the command line" print "(A)", "Options:" print "(A)", "-h, --help display this help and exit" print "(A)", " --banner display banner at startup (default)" print "(A)", " --no-banner do not display banner at startup" print "(A)", " --debug AREA switch on debug output for AREA." print "(A)", " AREA can be one of Whizard's src dirs or 'all'" print "(A)", " --debug2 AREA switch on more verbose debug output for AREA." print "(A)", "-V, --version output version information and exit" print "(A)", " --check TEST run unit test TEST" end subroutine print_usage @ %def main_ut @ <>= @ <>= @ @ MPI init. <>= call MPI_init () <>= call MPI_finalize () @ %def MPI_init MPI_finalize <>= @ Every rebuild action is forbidden for the slave workers except [[rebuild_grids]], which is handled correctly inside the corresponding integration object. <>= if (.not. mpi_is_comm_master ()) then options%rebuild_library = .false. options%recompile_library = .false. options%rebuild_user = .false. options%rebuild_phs = .false. options%rebuild_events = .false. end if @ \subsection{Self-tests} For those self-tests, we need some auxiliary routines that provide an enviroment. The environment depends on things that are not available at the level of the module that we want to test. \subsubsection{Testbed for event I/O} This subroutine prepares a test process with a single event. All objects are allocated via anonymous pointers, because we want to recover the pointers and delete the objects in a separate procedure. <>= subroutine prepare_eio_test (event, unweighted, n_alt) use variables, only: var_list_t use model_data use process, only: process_t use instances, only: process_instance_t use processes_ut, only: prepare_test_process use event_base use events class(generic_event_t), intent(inout), pointer :: event logical, intent(in), optional :: unweighted integer, intent(in), optional :: n_alt type(model_data_t), pointer :: model type(var_list_t) :: var_list type(process_t), pointer :: proc type(process_instance_t), pointer :: process_instance allocate (model) call model%init_test () allocate (proc) allocate (process_instance) call prepare_test_process (proc, process_instance, model, & run_id = var_str ("run_test")) call process_instance%setup_event_data () call model%final () deallocate (model) allocate (event_t :: event) select type (event) type is (event_t) if (present (unweighted)) then call var_list%append_log (& var_str ("?unweighted"), unweighted, & intrinsic = .true.) else call var_list%append_log (& var_str ("?unweighted"), .true., & intrinsic = .true.) end if call var_list%append_string (& var_str ("$sample_normalization"), & var_str ("auto"), intrinsic = .true.) call event%basic_init (var_list, n_alt) call event%connect (process_instance, proc%get_model_ptr ()) call var_list%final () end select end subroutine prepare_eio_test @ %def prepare_eio_test_event @ Recover those pointers, finalize the objects and deallocate. <>= subroutine cleanup_eio_test (event) use model_data use process, only: process_t use instances, only: process_instance_t use processes_ut, only: cleanup_test_process use event_base use events class(generic_event_t), intent(inout), pointer :: event type(process_t), pointer :: proc type(process_instance_t), pointer :: process_instance select type (event) type is (event_t) proc => event%get_process_ptr () process_instance => event%get_process_instance_ptr () call cleanup_test_process (proc, process_instance) deallocate (process_instance) deallocate (proc) call event%final () end select deallocate (event) end subroutine cleanup_eio_test @ %def cleanup_eio_test_event @ Assign those procedures to appropriate pointers (module variables) in the [[eio_base]] module, so they can be called as if they were module procedures. <>= use eio_base_ut, only: eio_prepare_test use eio_base_ut, only: eio_cleanup_test <>= eio_prepare_test => prepare_eio_test eio_cleanup_test => cleanup_eio_test @ \subsubsection{Any Model} This procedure reads any model from file and, optionally, assigns a var-list pointer. If the model pointer is still null, we allocate the model object first, with concrete type [[model_t]]. This is a service for modules which do just have access to the [[model_data_t]] base type. <>= subroutine prepare_whizard_model (model, name, vars) <> use os_interface use model_data use var_base use models class(model_data_t), intent(inout), pointer :: model type(string_t), intent(in) :: name class(vars_t), pointer, intent(out), optional :: vars type(os_data_t) :: os_data call syntax_model_file_init () call os_data%init () if (.not. associated (model)) allocate (model_t :: model) select type (model) type is (model_t) call model%read (name // ".mdl", os_data) if (present (vars)) then vars => model%get_var_list_ptr () end if end select end subroutine prepare_whizard_model @ %def prepare_whizard_model @ Cleanup after use. Includes deletion of the model-file syntax. <>= subroutine cleanup_whizard_model (model) use model_data use models class(model_data_t), intent(inout), target :: model call model%final () call syntax_model_file_final () end subroutine cleanup_whizard_model @ %def cleanup_whizard_model @ Assign those procedures to appropriate pointers (module variables) in the [[model_testbed]] module, so they can be called as if they were module procedures. <>= prepare_model => prepare_whizard_model cleanup_model => cleanup_whizard_model @ \subsubsection{Fallback model: hadrons} Some event format tests require the hadronic SM implementation, which has to be read from file. We provide the functionality here, so the tests do not depend on model I/O. <>= subroutine prepare_fallback_model (model) use model_data class(model_data_t), intent(inout), pointer :: model call prepare_whizard_model (model, var_str ("SM_hadrons")) end subroutine prepare_fallback_model @ %def prepare_fallback_model @ Assign those procedures to appropriate pointers (module variables) in the [[eio_base]] module, so they can be called as if they were module procedures. <>= use eio_base_ut, only: eio_prepare_fallback_model use eio_base_ut, only: eio_cleanup_fallback_model <>= eio_prepare_fallback_model => prepare_fallback_model eio_cleanup_fallback_model => cleanup_model @ \subsubsection{Access to the test random-number generator} This generator is not normally available for the dispatcher. We assign an additional dispatch routine to the hook in the [[dispatch]] module which will be checked before the default rule. <>= use dispatch_rng, only: dispatch_rng_factory_fallback use dispatch_rng_ut, only: dispatch_rng_factory_test <>= dispatch_rng_factory_fallback => dispatch_rng_factory_test @ \subsubsection{Access to the test structure functions} These are not normally available for the dispatcher. We assign an additional dispatch routine to the hook in the [[dispatch]] module which will be checked before the default rule. <>= use dispatch_beams, only: dispatch_sf_data_extra use dispatch_ut, only: dispatch_sf_data_test <>= dispatch_sf_data_extra => dispatch_sf_data_test @ \subsubsection{Procedure for Checking} This is for developers only, but needs a well-defined interface. <>= subroutine whizard_check (check, results) type(string_t), intent(in) :: check type(test_results_t), intent(inout) :: results type(os_data_t) :: os_data integer :: u call os_data%init () u = free_unit () open (u, file="whizard_check." // char (check) // ".log", & action="write", status="replace") call msg_message (repeat ('=', 76), 0) call msg_message ("Running self-test: " // char (check), 0) call msg_message (repeat ('-', 76), 0) <> select case (char (check)) <> case ("all") <> case default call msg_fatal ("Self-test '" // char (check) // "' not implemented.") end select close (u) end subroutine whizard_check @ %def whizard_check @ \subsection{Unit test references} \subsubsection{Formats} <>= use formats_ut, only: format_test <>= case ("formats") call format_test (u, results) <>= call format_test (u, results) @ \subsubsection{MD5} <>= use md5_ut, only: md5_test <>= case ("md5") call md5_test (u, results) <>= call md5_test (u, results) @ \subsubsection{OS Interface} <>= use os_interface_ut, only: os_interface_test <>= case ("os_interface") call os_interface_test (u, results) <>= call os_interface_test (u, results) @ \subsubsection{Sorting} <>= use sorting_ut, only: sorting_test <>= case ("sorting") call sorting_test (u, results) <>= call sorting_test (u, results) @ \subsubsection{Grids} <>= use grids_ut, only: grids_test <>= case ("grids") call grids_test (u, results) <>= call grids_test (u, results) @ \subsubsection{Solver} <>= use solver_ut, only: solver_test <>= case ("solver") call solver_test (u, results) <>= call solver_test (u, results) @ \subsubsection{CPU Time} <>= use cputime_ut, only: cputime_test <>= case ("cputime") call cputime_test (u, results) <>= call cputime_test (u, results) @ \subsubsection{SM QCD} <>= use sm_qcd_ut, only: sm_qcd_test <>= case ("sm_qcd") call sm_qcd_test (u, results) <>= call sm_qcd_test (u, results) @ \subsubsection{SM physics} <>= use sm_physics_ut, only: sm_physics_test <>= case ("sm_physics") call sm_physics_test (u, results) <>= call sm_physics_test (u, results) @ \subsubsection{Lexers} <>= use lexers_ut, only: lexer_test <>= case ("lexers") call lexer_test (u, results) <>= call lexer_test (u, results) @ \subsubsection{Parser} <>= use parser_ut, only: parse_test <>= case ("parser") call parse_test (u, results) <>= call parse_test (u, results) @ \subsubsection{XML} <>= use xml_ut, only: xml_test <>= case ("xml") call xml_test (u, results) <>= call xml_test (u, results) @ \subsubsection{Colors} <>= use colors_ut, only: color_test <>= case ("colors") call color_test (u, results) <>= call color_test (u, results) @ \subsubsection{State matrices} <>= use state_matrices_ut, only: state_matrix_test <>= case ("state_matrices") call state_matrix_test (u, results) <>= call state_matrix_test (u, results) @ \subsubsection{Analysis} <>= use analysis_ut, only: analysis_test <>= case ("analysis") call analysis_test (u, results) <>= call analysis_test (u, results) @ \subsubsection{Particles} <>= use particles_ut, only: particles_test <>= case ("particles") call particles_test (u, results) <>= call particles_test (u, results) @ \subsubsection{Models} <>= use models_ut, only: models_test <>= case ("models") call models_test (u, results) <>= call models_test (u, results) @ \subsubsection{Auto Components} <>= use auto_components_ut, only: auto_components_test <>= case ("auto_components") call auto_components_test (u, results) <>= call auto_components_test (u, results) @ \subsubsection{Radiation Generator} <>= use radiation_generator_ut, only: radiation_generator_test <>= case ("radiation_generator") call radiation_generator_test (u, results) <>= call radiation_generator_test (u, results) @ \subsection{BLHA} <>= use blha_ut, only: blha_test <>= case ("blha") call blha_test (u, results) <>= call blha_test (u, results) @ \subsubsection{Evaluators} <>= use evaluators_ut, only: evaluator_test <>= case ("evaluators") call evaluator_test (u, results) <>= call evaluator_test (u, results) @ \subsubsection{Expressions} <>= use eval_trees_ut, only: expressions_test <>= case ("expressions") call expressions_test (u, results) <>= call expressions_test (u, results) @ \subsubsection{Resonances} <>= use resonances_ut, only: resonances_test <>= case ("resonances") call resonances_test (u, results) <>= call resonances_test (u, results) @ \subsubsection{PHS Trees} <>= use phs_trees_ut, only: phs_trees_test <>= case ("phs_trees") call phs_trees_test (u, results) <>= call phs_trees_test (u, results) @ \subsubsection{PHS Forests} <>= use phs_forests_ut, only: phs_forests_test <>= case ("phs_forests") call phs_forests_test (u, results) <>= call phs_forests_test (u, results) @ \subsubsection{Beams} <>= use beams_ut, only: beams_test <>= case ("beams") call beams_test (u, results) <>= call beams_test (u, results) @ \subsubsection{$su(N)$ Algebra} <>= use su_algebra_ut, only: su_algebra_test <>= case ("su_algebra") call su_algebra_test (u, results) <>= call su_algebra_test (u, results) @ \subsubsection{Bloch Vectors} <>= use bloch_vectors_ut, only: bloch_vectors_test <>= case ("bloch_vectors") call bloch_vectors_test (u, results) <>= call bloch_vectors_test (u, results) @ \subsubsection{Polarizations} <>= use polarizations_ut, only: polarizations_test <>= case ("polarizations") call polarizations_test (u, results) <>= call polarizations_test (u, results) @ \subsubsection{SF Aux} <>= use sf_aux_ut, only: sf_aux_test <>= case ("sf_aux") call sf_aux_test (u, results) <>= call sf_aux_test (u, results) @ \subsubsection{SF Mappings} <>= use sf_mappings_ut, only: sf_mappings_test <>= case ("sf_mappings") call sf_mappings_test (u, results) <>= call sf_mappings_test (u, results) @ \subsubsection{SF Base} <>= use sf_base_ut, only: sf_base_test <>= case ("sf_base") call sf_base_test (u, results) <>= call sf_base_test (u, results) @ \subsubsection{SF PDF Builtin} <>= use sf_pdf_builtin_ut, only: sf_pdf_builtin_test <>= case ("sf_pdf_builtin") call sf_pdf_builtin_test (u, results) <>= call sf_pdf_builtin_test (u, results) @ \subsubsection{SF LHAPDF} <>= use sf_lhapdf_ut, only: sf_lhapdf_test <>= case ("sf_lhapdf") call sf_lhapdf_test (u, results) <>= call sf_lhapdf_test (u, results) @ \subsubsection{SF ISR} <>= use sf_isr_ut, only: sf_isr_test <>= case ("sf_isr") call sf_isr_test (u, results) <>= call sf_isr_test (u, results) @ \subsubsection{SF EPA} <>= use sf_epa_ut, only: sf_epa_test <>= case ("sf_epa") call sf_epa_test (u, results) <>= call sf_epa_test (u, results) @ \subsubsection{SF EWA} <>= use sf_ewa_ut, only: sf_ewa_test <>= case ("sf_ewa") call sf_ewa_test (u, results) <>= call sf_ewa_test (u, results) @ \subsubsection{SF CIRCE1} <>= use sf_circe1_ut, only: sf_circe1_test <>= case ("sf_circe1") call sf_circe1_test (u, results) <>= call sf_circe1_test (u, results) @ \subsubsection{SF CIRCE2} <>= use sf_circe2_ut, only: sf_circe2_test <>= case ("sf_circe2") call sf_circe2_test (u, results) <>= call sf_circe2_test (u, results) @ \subsubsection{SF Gaussian} <>= use sf_gaussian_ut, only: sf_gaussian_test <>= case ("sf_gaussian") call sf_gaussian_test (u, results) <>= call sf_gaussian_test (u, results) @ \subsubsection{SF Beam Events} <>= use sf_beam_events_ut, only: sf_beam_events_test <>= case ("sf_beam_events") call sf_beam_events_test (u, results) <>= call sf_beam_events_test (u, results) @ \subsubsection{SF EScan} <>= use sf_escan_ut, only: sf_escan_test <>= case ("sf_escan") call sf_escan_test (u, results) <>= call sf_escan_test (u, results) @ \subsubsection{PHS Base} <>= use phs_base_ut, only: phs_base_test <>= case ("phs_base") call phs_base_test (u, results) <>= call phs_base_test (u, results) @ \subsubsection{PHS None} <>= use phs_none_ut, only: phs_none_test <>= case ("phs_none") call phs_none_test (u, results) <>= call phs_none_test (u, results) @ \subsubsection{PHS Single} <>= use phs_single_ut, only: phs_single_test <>= case ("phs_single") call phs_single_test (u, results) <>= call phs_single_test (u, results) @ \subsubsection{PHS Rambo} <>= use phs_rambo_ut, only: phs_rambo_test <>= case ("phs_rambo") call phs_rambo_test (u, results) <>= call phs_rambo_test (u, results) @ \subsubsection{PHS Wood} <>= use phs_wood_ut, only: phs_wood_test use phs_wood_ut, only: phs_wood_vis_test <>= case ("phs_wood") call phs_wood_test (u, results) case ("phs_wood_vis") call phs_wood_vis_test (u, results) <>= call phs_wood_test (u, results) call phs_wood_vis_test (u, results) @ \subsubsection{PHS FKS Generator} <>= use phs_fks_ut, only: phs_fks_generator_test <>= case ("phs_fks_generator") call phs_fks_generator_test (u, results) <>= call phs_fks_generator_test (u, results) @ \subsubsection{FKS regions} <>= use fks_regions_ut, only: fks_regions_test <>= case ("fks_regions") call fks_regions_test (u, results) <>= call fks_regions_test (u, results) @ \subsubsection{Real subtraction} <>= use real_subtraction_ut, only: real_subtraction_test <>= case ("real_subtraction") call real_subtraction_test (u, results) <>= call real_subtraction_test (u, results) @ \subsubsection{RECOLA} <>= use prc_recola_ut, only: prc_recola_test <>= case ("prc_recola") call prc_recola_test (u, results) <>= call prc_recola_test (u, results) @ \subsubsection{RNG Base} <>= use rng_base_ut, only: rng_base_test <>= case ("rng_base") call rng_base_test (u, results) <>= call rng_base_test (u, results) @ \subsubsection{RNG Tao} <>= use rng_tao_ut, only: rng_tao_test <>= case ("rng_tao") call rng_tao_test (u, results) <>= call rng_tao_test (u, results) @ \subsubsection{RNG Stream} <>= use rng_stream_ut, only: rng_stream_test <>= case ("rng_stream") call rng_stream_test (u, results) <>= call rng_stream_test (u, results) @ \subsubsection{Selectors} <>= use selectors_ut, only: selectors_test <>= case ("selectors") call selectors_test (u, results) <>= call selectors_test (u, results) @ \subsubsection{VEGAS} <>= use vegas_ut, only: vegas_test <>= case ("vegas") call vegas_test (u, results) <>= call vegas_test (u, results) @ \subsubsection{VAMP2} <>= use vamp2_ut, only: vamp2_test <>= case ("vamp2") call vamp2_test (u, results) <>= call vamp2_test (u, results) @ \subsubsection{MCI Base} <>= use mci_base_ut, only: mci_base_test <>= case ("mci_base") call mci_base_test (u, results) <>= call mci_base_test (u, results) @ \subsubsection{MCI None} <>= use mci_none_ut, only: mci_none_test <>= case ("mci_none") call mci_none_test (u, results) <>= call mci_none_test (u, results) @ \subsubsection{MCI Midpoint} <>= use mci_midpoint_ut, only: mci_midpoint_test <>= case ("mci_midpoint") call mci_midpoint_test (u, results) <>= call mci_midpoint_test (u, results) @ \subsubsection{MCI VAMP} <>= use mci_vamp_ut, only: mci_vamp_test <>= case ("mci_vamp") call mci_vamp_test (u, results) <>= call mci_vamp_test (u, results) @ \subsubsection{MCI VAMP2} <>= use mci_vamp2_ut, only: mci_vamp2_test <>= case ("mci_vamp2") call mci_vamp2_test (u, results) <>= call mci_vamp2_test (u, results) @ \subsubsection{Integration Results} <>= use integration_results_ut, only: integration_results_test <>= case ("integration_results") call integration_results_test (u, results) <>= call integration_results_test (u, results) @ \subsubsection{PRCLib Interfaces} <>= use prclib_interfaces_ut, only: prclib_interfaces_test <>= case ("prclib_interfaces") call prclib_interfaces_test (u, results) <>= call prclib_interfaces_test (u, results) @ \subsubsection{Particle Specifiers} <>= use particle_specifiers_ut, only: particle_specifiers_test <>= case ("particle_specifiers") call particle_specifiers_test (u, results) <>= call particle_specifiers_test (u, results) @ \subsubsection{Process Libraries} <>= use process_libraries_ut, only: process_libraries_test <>= case ("process_libraries") call process_libraries_test (u, results) <>= call process_libraries_test (u, results) @ \subsubsection{PRCLib Stacks} <>= use prclib_stacks_ut, only: prclib_stacks_test <>= case ("prclib_stacks") call prclib_stacks_test (u, results) <>= call prclib_stacks_test (u, results) @ \subsubsection{HepMC} <>= use hepmc_interface_ut, only: hepmc_interface_test <>= case ("hepmc") call hepmc_interface_test (u, results) <>= call hepmc_interface_test (u, results) @ \subsubsection{LCIO} <>= use lcio_interface_ut, only: lcio_interface_test <>= case ("lcio") call lcio_interface_test (u, results) <>= call lcio_interface_test (u, results) @ \subsubsection{Jets} <>= use jets_ut, only: jets_test <>= case ("jets") call jets_test (u, results) <>= call jets_test (u, results) @ \subsection{LHA User Process WHIZARD} <>= use whizard_lha_ut, only: whizard_lha_test <>= case ("whizard_lha") call whizard_lha_test (u, results) <>= call whizard_lha_test (u, results) @ \subsection{Pythia8} <>= use pythia8_ut, only: pythia8_test <>= case ("pythia8") call pythia8_test (u, results) <>= call pythia8_test (u, results) @ \subsubsection{PDG Arrays} <>= use pdg_arrays_ut, only: pdg_arrays_test <>= case ("pdg_arrays") call pdg_arrays_test (u, results) <>= call pdg_arrays_test (u, results) @ \subsubsection{interactions} <>= use interactions_ut, only: interaction_test <>= case ("interactions") call interaction_test (u, results) <>= call interaction_test (u, results) @ \subsubsection{SLHA} <>= use slha_interface_ut, only: slha_test <>= case ("slha_interface") call slha_test (u, results) <>= call slha_test (u, results) @ \subsubsection{Cascades} <>= use cascades_ut, only: cascades_test <>= case ("cascades") call cascades_test (u, results) <>= call cascades_test (u, results) @ \subsubsection{Cascades2 lexer} <>= use cascades2_lexer_ut, only: cascades2_lexer_test <>= case ("cascades2_lexer") call cascades2_lexer_test (u, results) <>= call cascades2_lexer_test (u, results) @ \subsubsection{Cascades2} <>= use cascades2_ut, only: cascades2_test <>= case ("cascades2") call cascades2_test (u, results) <>= call cascades2_test (u, results) @ \subsubsection{PRC Test} <>= use prc_test_ut, only: prc_test_test <>= case ("prc_test") call prc_test_test (u, results) <>= call prc_test_test (u, results) @ \subsubsection{PRC Template ME} <>= use prc_template_me_ut, only: prc_template_me_test <>= case ("prc_template_me") call prc_template_me_test (u, results) <>= call prc_template_me_test (u, results) @ \subsubsection{PRC OMega} <>= use prc_omega_ut, only: prc_omega_test use prc_omega_ut, only: prc_omega_diags_test <>= case ("prc_omega") call prc_omega_test (u, results) case ("prc_omega_diags") call prc_omega_diags_test (u, results) <>= call prc_omega_test (u, results) call prc_omega_diags_test (u, results) @ \subsubsection{Parton States} <>= use parton_states_ut, only: parton_states_test <>= case ("parton_states") call parton_states_test (u, results) <>= call parton_states_test (u, results) @ \subsubsection{Subevt Expr} <>= use expr_tests_ut, only: subevt_expr_test <>= case ("subevt_expr") call subevt_expr_test (u, results) <>= call subevt_expr_test (u, results) @ \subsubsection{Processes} <>= use processes_ut, only: processes_test <>= case ("processes") call processes_test (u, results) <>= call processes_test (u, results) @ \subsubsection{Process Stacks} <>= use process_stacks_ut, only: process_stacks_test <>= case ("process_stacks") call process_stacks_test (u, results) <>= call process_stacks_test (u, results) @ \subsubsection{Event Transforms} <>= use event_transforms_ut, only: event_transforms_test <>= case ("event_transforms") call event_transforms_test (u, results) <>= call event_transforms_test (u, results) @ \subsubsection{Resonance Insertion Transform} <>= use resonance_insertion_ut, only: resonance_insertion_test <>= case ("resonance_insertion") call resonance_insertion_test (u, results) <>= call resonance_insertion_test (u, results) @ \subsubsection{Recoil Kinematics} <>= use recoil_kinematics_ut, only: recoil_kinematics_test <>= case ("recoil_kinematics") call recoil_kinematics_test (u, results) <>= call recoil_kinematics_test (u, results) @ \subsubsection{ISR Handler} <>= use isr_epa_handler_ut, only: isr_handler_test <>= case ("isr_handler") call isr_handler_test (u, results) <>= call isr_handler_test (u, results) @ \subsubsection{EPA Handler} <>= use isr_epa_handler_ut, only: epa_handler_test <>= case ("epa_handler") call epa_handler_test (u, results) <>= call epa_handler_test (u, results) @ \subsubsection{Decays} <>= use decays_ut, only: decays_test <>= case ("decays") call decays_test (u, results) <>= call decays_test (u, results) @ \subsubsection{Shower} <>= use shower_ut, only: shower_test <>= case ("shower") call shower_test (u, results) <>= call shower_test (u, results) @ \subsubsection{Events} <>= use events_ut, only: events_test <>= case ("events") call events_test (u, results) <>= call events_test (u, results) @ \subsubsection{HEP Events} <>= use hep_events_ut, only: hep_events_test <>= case ("hep_events") call hep_events_test (u, results) <>= call hep_events_test (u, results) @ \subsubsection{EIO Data} <>= use eio_data_ut, only: eio_data_test <>= case ("eio_data") call eio_data_test (u, results) <>= call eio_data_test (u, results) @ \subsubsection{EIO Base} <>= use eio_base_ut, only: eio_base_test <>= case ("eio_base") call eio_base_test (u, results) <>= call eio_base_test (u, results) @ \subsubsection{EIO Direct} <>= use eio_direct_ut, only: eio_direct_test <>= case ("eio_direct") call eio_direct_test (u, results) <>= call eio_direct_test (u, results) @ \subsubsection{EIO Raw} <>= use eio_raw_ut, only: eio_raw_test <>= case ("eio_raw") call eio_raw_test (u, results) <>= call eio_raw_test (u, results) @ \subsubsection{EIO Checkpoints} <>= use eio_checkpoints_ut, only: eio_checkpoints_test <>= case ("eio_checkpoints") call eio_checkpoints_test (u, results) <>= call eio_checkpoints_test (u, results) @ \subsubsection{EIO LHEF} <>= use eio_lhef_ut, only: eio_lhef_test <>= case ("eio_lhef") call eio_lhef_test (u, results) <>= call eio_lhef_test (u, results) @ \subsubsection{EIO HepMC} <>= use eio_hepmc_ut, only: eio_hepmc_test <>= case ("eio_hepmc") call eio_hepmc_test (u, results) <>= call eio_hepmc_test (u, results) @ \subsubsection{EIO LCIO} <>= use eio_lcio_ut, only: eio_lcio_test <>= case ("eio_lcio") call eio_lcio_test (u, results) <>= call eio_lcio_test (u, results) @ \subsubsection{EIO StdHEP} <>= use eio_stdhep_ut, only: eio_stdhep_test <>= case ("eio_stdhep") call eio_stdhep_test (u, results) <>= call eio_stdhep_test (u, results) @ \subsubsection{EIO ASCII} <>= use eio_ascii_ut, only: eio_ascii_test <>= case ("eio_ascii") call eio_ascii_test (u, results) <>= call eio_ascii_test (u, results) @ \subsubsection{EIO Weights} <>= use eio_weights_ut, only: eio_weights_test <>= case ("eio_weights") call eio_weights_test (u, results) <>= call eio_weights_test (u, results) @ \subsubsection{EIO Dump} <>= use eio_dump_ut, only: eio_dump_test <>= case ("eio_dump") call eio_dump_test (u, results) <>= call eio_dump_test (u, results) @ \subsubsection{Iterations} <>= use iterations_ut, only: iterations_test <>= case ("iterations") call iterations_test (u, results) <>= call iterations_test (u, results) @ \subsubsection{Beam Structures} <>= use beam_structures_ut, only: beam_structures_test <>= case ("beam_structures") call beam_structures_test (u, results) <>= call beam_structures_test (u, results) @ \subsubsection{RT Data} <>= use rt_data_ut, only: rt_data_test <>= case ("rt_data") call rt_data_test (u, results) <>= call rt_data_test (u, results) @ \subsubsection{Dispatch} <>= use dispatch_ut, only: dispatch_test <>= case ("dispatch") call dispatch_test (u, results) <>= call dispatch_test (u, results) @ \subsubsection{Dispatch RNG} <>= use dispatch_rng_ut, only: dispatch_rng_test <>= case ("dispatch_rng") call dispatch_rng_test (u, results) <>= call dispatch_rng_test (u, results) @ \subsubsection{Dispatch MCI} <>= use dispatch_mci_ut, only: dispatch_mci_test <>= case ("dispatch_mci") call dispatch_mci_test (u, results) <>= call dispatch_mci_test (u, results) @ \subsubsection{Dispatch PHS} <>= use dispatch_phs_ut, only: dispatch_phs_test <>= case ("dispatch_phs") call dispatch_phs_test (u, results) <>= call dispatch_phs_test (u, results) @ \subsubsection{Dispatch transforms} <>= use dispatch_transforms_ut, only: dispatch_transforms_test <>= case ("dispatch_transforms") call dispatch_transforms_test (u, results) <>= call dispatch_transforms_test (u, results) @ \subsubsection{Shower partons} <>= use shower_base_ut, only: shower_base_test <>= case ("shower_base") call shower_base_test (u, results) <>= call shower_base_test (u, results) @ \subsubsection{Process Configurations} <>= use process_configurations_ut, only: process_configurations_test <>= case ("process_configurations") call process_configurations_test (u, results) <>= call process_configurations_test (u, results) @ \subsubsection{Compilations} <>= use compilations_ut, only: compilations_test use compilations_ut, only: compilations_static_test <>= case ("compilations") call compilations_test (u, results) case ("compilations_static") call compilations_static_test (u, results) <>= call compilations_test (u, results) call compilations_static_test (u, results) @ \subsubsection{Integrations} <>= use integrations_ut, only: integrations_test use integrations_ut, only: integrations_history_test <>= case ("integrations") call integrations_test (u, results) case ("integrations_history") call integrations_history_test (u, results) <>= call integrations_test (u, results) call integrations_history_test (u, results) @ \subsubsection{Event Streams} <>= use event_streams_ut, only: event_streams_test <>= case ("event_streams") call event_streams_test (u, results) <>= call event_streams_test (u, results) @ \subsubsection{Restricted Subprocesses} <>= use restricted_subprocesses_ut, only: restricted_subprocesses_test <>= case ("restricted_subprocesses") call restricted_subprocesses_test (u, results) <>= call restricted_subprocesses_test (u, results) @ \subsubsection{Simulations} <>= use simulations_ut, only: simulations_test <>= case ("simulations") call simulations_test (u, results) <>= call simulations_test (u, results) @ \subsubsection{Commands} <>= use commands_ut, only: commands_test <>= case ("commands") call commands_test (u, results) <>= call commands_test (u, results) @ \subsubsection{$ttV$ formfactors} <>= use ttv_formfactors_ut, only: ttv_formfactors_test <>= case ("ttv_formfactors") call ttv_formfactors_test (u, results) <>= call ttv_formfactors_test (u, results) @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Whizard-C-Interface} <<[[whizard-c-interface.f90]]>>= <> <> <> <> <> @ <>= subroutine c_whizard_convert_string (c_string, f_string) use, intrinsic :: iso_c_binding use iso_varying_string, string_t => varying_string !NODEP! implicit none character(kind=c_char), intent(in) :: c_string(*) type(string_t), intent(inout) :: f_string character(len=1) :: dummy_char integer :: dummy_i = 1 f_string = "" do if (c_string(dummy_i) == c_null_char) then exit else if (c_string(dummy_i) == c_new_line) then dummy_char = CHAR(13) f_string = f_string // dummy_char dummy_char = CHAR(10) else dummy_char = c_string (dummy_i) end if f_string = f_string // dummy_char dummy_i = dummy_i + 1 end do dummy_i = 1 end subroutine c_whizard_convert_string subroutine c_whizard_commands (w_c_instance, cmds) use, intrinsic :: iso_c_binding use iso_varying_string, string_t => varying_string !NODEP! use commands use diagnostics use lexers use models use parser use whizard type(c_ptr), intent(inout) :: w_c_instance type(whizard_t), pointer :: whizard_instance type(string_t) :: cmds type(parse_tree_t) :: parse_tree type(parse_node_t), pointer :: pn_root type(stream_t), target :: stream type(lexer_t) :: lexer type(command_list_t), target :: cmd_list call c_f_pointer (w_c_instance, whizard_instance) call lexer_init_cmd_list (lexer) call syntax_cmd_list_init () call stream_init (stream, cmds) call lexer_assign_stream (lexer, stream) call parse_tree_init (parse_tree, syntax_cmd_list, lexer) pn_root => parse_tree%get_root_ptr () if (associated (pn_root)) then call cmd_list%compile (pn_root, whizard_instance%global) end if call whizard_instance%global%activate () call cmd_list%execute (whizard_instance%global) call cmd_list%final () call parse_tree_final (parse_tree) call stream_final (stream) call lexer_final (lexer) call syntax_cmd_list_final () end subroutine c_whizard_commands @ <>= subroutine c_whizard_init (w_c_instance) bind(C) use, intrinsic :: iso_c_binding use iso_varying_string, string_t => varying_string !NODEP! use system_dependencies use diagnostics use ifiles use os_interface use whizard implicit none <> type(c_ptr), intent(out) :: w_c_instance logical :: banner type(string_t) :: files, model, default_lib, library, libraries ! type(string_t) :: check, checks type(string_t) :: logfile type(string_t) :: user_src, user_lib type(paths_t) :: paths logical :: rebuild_library, rebuild_user logical :: rebuild_phs, rebuild_grids, rebuild_events type(whizard_options_t), allocatable :: options type(whizard_t), pointer :: whizard_instance ! Initial values files = "" model = "SM" default_lib = "default_lib" library = "" libraries = "" banner = .true. logging = .true. logfile = "whizard.log" ! check = "" ! checks = "" user_src = "" user_lib = "" rebuild_library = .false. rebuild_user = .false. rebuild_phs = .false. rebuild_grids = .false. rebuild_events = .false. call paths_init (paths) ! Overall initialization if (logfile /= "") call logfile_init (logfile) call mask_term_signals () if (banner) call msg_banner () ! Set options and initialize the whizard object allocate (options) options%preload_model = model options%default_lib = default_lib options%preload_libraries = libraries options%rebuild_library = rebuild_library options%rebuild_user = rebuild_user options%rebuild_phs = rebuild_phs options%rebuild_grids = rebuild_grids options%rebuild_events = rebuild_events allocate (whizard_instance) call whizard_instance%init (options, paths) ! if (checks /= "") then ! checks = trim (adjustl (checks)) ! RUN_CHECKS: do while (checks /= "") ! call split (checks, check, " ") ! call whizard_check (check, test_results) ! end do RUN_CHECKS ! call test_results%wrapup (6, success) ! if (.not. success) quit_code = 7 ! quit = .true. ! end if w_c_instance = c_loc (whizard_instance) end subroutine c_whizard_init subroutine c_whizard_finalize (w_c_instance) bind(C) use, intrinsic :: iso_c_binding use system_dependencies use diagnostics use ifiles use os_interface use whizard type(c_ptr), intent(in) :: w_c_instance type(whizard_t), pointer :: whizard_instance integer :: quit_code = 0 call c_f_pointer (w_c_instance, whizard_instance) call whizard_instance%final () deallocate (whizard_instance) call terminate_now_if_signal () call release_term_signals () call msg_terminate (quit_code = quit_code) end subroutine c_whizard_finalize subroutine c_whizard_process_string (w_c_instance, c_cmds_in) bind(C) use, intrinsic :: iso_c_binding use iso_varying_string, string_t => varying_string !NODEP! implicit none type(c_ptr), intent(inout) :: w_c_instance character(kind=c_char) :: c_cmds_in(*) type(string_t) :: f_cmds call c_whizard_convert_string (c_cmds_in, f_cmds) call c_whizard_commands (w_c_instance, f_cmds) end subroutine c_whizard_process_string @ <>= subroutine c_whizard_model (w_c_instance, c_model) bind(C) use, intrinsic :: iso_c_binding use iso_varying_string, string_t => varying_string !NODEP! implicit none type(c_ptr), intent(inout) :: w_c_instance character(kind=c_char) :: c_model(*) type(string_t) :: model, mdl_str call c_whizard_convert_string (c_model, model) mdl_str = "model = " // model call c_whizard_commands (w_c_instance, mdl_str) end subroutine c_whizard_model subroutine c_whizard_library (w_c_instance, c_library) bind(C) use, intrinsic :: iso_c_binding use iso_varying_string, string_t => varying_string !NODEP! implicit none type(c_ptr), intent(inout) :: w_c_instance character(kind=c_char) :: c_library(*) type(string_t) :: library, lib_str call c_whizard_convert_string(c_library, library) lib_str = "library = " // library call c_whizard_commands (w_c_instance, lib_str) end subroutine c_whizard_library subroutine c_whizard_process (w_c_instance, c_id, c_in, c_out) bind(C) use, intrinsic :: iso_c_binding use iso_varying_string, string_t => varying_string !NODEP! implicit none type(c_ptr), intent(inout) :: w_c_instance character(kind=c_char) :: c_id(*), c_in(*), c_out(*) type(string_t) :: proc_str, id, in, out call c_whizard_convert_string (c_id, id) call c_whizard_convert_string (c_in, in) call c_whizard_convert_string (c_out, out) proc_str = "process " // id // " = " // in // " => " // out call c_whizard_commands (w_c_instance, proc_str) end subroutine c_whizard_process subroutine c_whizard_compile (w_c_instance) bind(C) use, intrinsic :: iso_c_binding use iso_varying_string, string_t => varying_string !NODEP! type(c_ptr), intent(inout) :: w_c_instance type(string_t) :: cmp_str cmp_str = "compile" call c_whizard_commands (w_c_instance, cmp_str) end subroutine c_whizard_compile subroutine c_whizard_beams (w_c_instance, c_specs) bind(C) use, intrinsic :: iso_c_binding use iso_varying_string, string_t => varying_string !NODEP! implicit none type(c_ptr), intent(inout) :: w_c_instance character(kind=c_char) :: c_specs(*) type(string_t) :: specs, beam_str call c_whizard_convert_string (c_specs, specs) beam_str = "beams = " // specs call c_whizard_commands (w_c_instance, beam_str) end subroutine c_whizard_beams subroutine c_whizard_integrate (w_c_instance, c_process) bind(C) use, intrinsic :: iso_c_binding use iso_varying_string, string_t => varying_string !NODEP! implicit none type(c_ptr), intent(inout) :: w_c_instance character(kind=c_char) :: c_process(*) type(string_t) :: process, int_str call c_whizard_convert_string (c_process, process) int_str = "integrate (" // process //")" call c_whizard_commands (w_c_instance, int_str) end subroutine c_whizard_integrate subroutine c_whizard_matrix_element_test & (w_c_instance, c_process, n_calls) bind(C) use, intrinsic :: iso_c_binding use iso_varying_string, string_t => varying_string !NODEP! implicit none type(c_ptr), intent(inout) :: w_c_instance integer(kind=c_int) :: n_calls character(kind=c_char) :: c_process(*) type(string_t) :: process, me_str character(len=8) :: buffer call c_whizard_convert_string (c_process, process) write (buffer, "(I0)") n_calls me_str = "integrate (" // process // ") { ?phs_only = true" // & " n_calls_test = " // trim (buffer) call c_whizard_commands (w_c_instance, me_str) end subroutine c_whizard_matrix_element_test subroutine c_whizard_simulate (w_c_instance, c_id) bind(C) use, intrinsic :: iso_c_binding use iso_varying_string, string_t => varying_string !NODEP! implicit none type(c_ptr), intent(inout) :: w_c_instance character(kind=c_char) :: c_id(*) type(string_t) :: sim_str, id call c_whizard_convert_string(c_id, id) sim_str = "simulate (" // id // ")" call c_whizard_commands (w_c_instance, sim_str) end subroutine c_whizard_simulate subroutine c_whizard_sqrts (w_c_instance, c_value, c_unit) bind(C) use, intrinsic :: iso_c_binding use iso_varying_string, string_t => varying_string !NODEP! implicit none type(c_ptr), intent(inout) :: w_c_instance character(kind=c_char) :: c_unit(*) integer(kind=c_int) :: c_value integer :: f_value character(len=8) :: f_val type(string_t) :: val, unit, sqrts_str f_value = c_value write (f_val,'(i8)') f_value val = f_val call c_whizard_convert_string (c_unit, unit) sqrts_str = "sqrts =" // val // unit call c_whizard_commands (w_c_instance, sqrts_str) end subroutine c_whizard_sqrts @ <>= type(c_ptr) function c_whizard_hepmc_test & (w_c_instance, c_id, c_proc_id, c_event_id) bind(C) use, intrinsic :: iso_c_binding use iso_varying_string, string_t => varying_string !NODEP! use commands use diagnostics use events use hepmc_interface use lexers use models use parser use instances use rt_data use simulations use whizard use os_interface implicit none type(c_ptr), intent(inout) :: w_c_instance type(string_t) :: sim_str type(parse_tree_t) :: parse_tree type(parse_node_t), pointer :: pn_root type(stream_t), target :: stream type(lexer_t) :: lexer type(command_list_t), pointer :: cmd_list type(whizard_t), pointer :: whizard_instance type(simulation_t), target :: sim character(kind=c_char), intent(in) :: c_id(*) type(string_t) :: id integer(kind=c_int), value :: c_proc_id, c_event_id integer :: proc_id type(hepmc_event_t), pointer :: hepmc_event call c_f_pointer (w_c_instance, whizard_instance) call c_whizard_convert_string (c_id, id) sim_str = "simulate (" // id // ")" proc_id = c_proc_id allocate (hepmc_event) call hepmc_event_init (hepmc_event, c_proc_id, c_event_id) call syntax_cmd_list_init () call lexer_init_cmd_list (lexer) call stream_init (stream, sim_str) call lexer_assign_stream (lexer, stream) call parse_tree_init (parse_tree, syntax_cmd_list, lexer) pn_root => parse_tree%get_root_ptr () allocate (cmd_list) if (associated (pn_root)) then call cmd_list%compile (pn_root, whizard_instance%global) end if call sim%init ([id], .true., .true., whizard_instance%global) !!! This should generate a HepMC event as hepmc_event_t type call msg_message ("Not enabled for the moment.") call sim%final () call cmd_list%final () call parse_tree_final (parse_tree) call stream_final (stream) call lexer_final (lexer) call syntax_cmd_list_final () c_whizard_hepmc_test = c_loc(hepmc_event) return end function c_whizard_hepmc_test @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%