Index: trunk/share/tests/functional_tests/ref-output/event_eff_2.ref =================================================================== --- trunk/share/tests/functional_tests/ref-output/event_eff_2.ref (revision 8827) +++ trunk/share/tests/functional_tests/ref-output/event_eff_2.ref (revision 8828) @@ -1,270 +1,276 @@ ?openmp_logging = false ?vis_history = false ?integration_timer = false seed = 0 $method = "omega" | Process library 'event_eff_2_lib': recorded process 'event_eff_2_p1' | Process library 'event_eff_2_lib': compiling ... | Process library 'event_eff_2_lib': writing makefile | Process library 'event_eff_2_lib': removing old files | Process library 'event_eff_2_lib': writing driver | Process library 'event_eff_2_lib': creating source code | Process library 'event_eff_2_lib': compiling sources | Process library 'event_eff_2_lib': linking | Process library 'event_eff_2_lib': loading | Process library 'event_eff_2_lib': ... success. $phs_method = "wood" $integration_method = "vamp2" sqrts = 1.000000000000E+03 openmp_num_threads = 1 n_events = 1000 | RNG: Initializing TAO random-number generator | RNG: Setting seed for random-number generator to 0 | Initializing integration for process event_eff_2_p1: | Beam structure: [any particles] | Beam data (collision): | e- (mass = 0.0000000E+00 GeV) | e+ (mass = 0.0000000E+00 GeV) | sqrts = 1.000000000000E+03 GeV | Phase space: generating configuration ... | Phase space: ... success. | Phase space: writing configuration file 'event_eff_2_p1.i1.phs' | ------------------------------------------------------------------------ | Process [scattering]: 'event_eff_2_p1' | Library name = 'event_eff_2_lib' | Process index = 1 | Process components: | 1: 'event_eff_2_p1_i1': e-, e+ => m-, m+ [omega] | ------------------------------------------------------------------------ | Phase space: 1 channels, 2 dimensions | Phase space: found 1 channel, collected in 1 grove. | Phase space: Using 1 equivalence between channels. | Phase space: wood Warning: No cuts have been defined. | Starting integration for process 'event_eff_2_p1' | Integrate: iterations = 3:1000:"g", 3:1000 | Integrator: 1 chains, 1 channels, 2 dimensions | Integrator: Using VAMP2 channel equivalences | Integrator: Write grid header and grids to 'event_eff_2_p1.m1.vg2' | Integrator: Grid checkpoint after each iteration | Integrator: 1000 initial calls, 20 max. bins, stratified = T | Integrator: VAMP2 |=============================================================================| | It Calls Integral[fb] Error[fb] Err[%] Acc Eff[%] Chi2 N[It] | |=============================================================================| | VAMP2: Initialize new grids and write to file 'event_eff_2_p1.m1.vg2'. | VAMP2: set chain: use chained weights. 1 800 8.6990044E+01 7.71E-02 0.09 0.03* 66.87 2 800 8.6815804E+01 6.11E-02 0.07 0.02* 49.78 3 800 8.6825431E+01 6.05E-02 0.07 0.02* 67.68 |-----------------------------------------------------------------------------| 3 2400 8.6860840E+01 3.75E-02 0.04 0.02 67.68 1.85 3 |-----------------------------------------------------------------------------| 4 800 8.6934756E+01 6.24E-02 0.07 0.02 70.88 5 800 8.7032837E+01 6.05E-02 0.07 0.02* 70.93 6 800 8.6972878E+01 6.29E-02 0.07 0.02 70.96 |-----------------------------------------------------------------------------| 6 2400 8.6981297E+01 3.57E-02 0.04 0.02 70.96 0.65 3 |=============================================================================| | Starting simulation for process 'event_eff_2_p1' | RNG: Initializing TAO random-number generator | RNG: Setting seed for random-number generator to 1 | Simulation: requested number of events = 1000 | corr. to luminosity [fb-1] = 1.1497E+01 | Events: writing to raw file 'event_eff_2_p1.evx' | Events: generating 1000 unweighted, unpolarized events ... | Events: event normalization mode '1' | ... event sample complete. | Events: actual unweighting efficiency = 71.63 % Warning: Encountered events with excess weight: 1 events ( 0.100 %) | Maximum excess weight = 6.353E-04 | Average excess weight = 6.353E-07 | Events: closing raw file 'event_eff_2_p1.evx' | RNG: Initializing TAO random-number generator | RNG: Setting seed for random-number generator to 2 | Initializing integration for process event_eff_2_p1: | Beam structure: [any particles] | Beam data (collision): | e- (mass = 0.0000000E+00 GeV) | e+ (mass = 0.0000000E+00 GeV) | sqrts = 1.000000000000E+03 GeV | Phase space: generating configuration ... | Phase space: ... success. | Phase space: writing configuration file 'event_eff_2_p1.i1.phs' | ------------------------------------------------------------------------ | Process [scattering]: 'event_eff_2_p1' | Library name = 'event_eff_2_lib' | Process index = 1 | Process components: | 1: 'event_eff_2_p1_i1': e-, e+ => m-, m+ [omega] | ------------------------------------------------------------------------ | Phase space: 1 channels, 2 dimensions | Phase space: found 1 channel, collected in 1 grove. | Phase space: Using 1 equivalence between channels. | Phase space: wood Warning: No cuts have been defined. | Using user-defined reweighting factor. | Starting integration for process 'event_eff_2_p1' | Integrate: iterations = 3:1000:"g", 3:1000 | Integrator: 1 chains, 1 channels, 2 dimensions | Integrator: Using VAMP2 channel equivalences | Integrator: Write grid header and grids to 'event_eff_2_p1.m1.vg2' | Integrator: Grid checkpoint after each iteration | Integrator: 1000 initial calls, 20 max. bins, stratified = T | Integrator: VAMP2 |=============================================================================| | It Calls Integral[fb] Error[fb] Err[%] Acc Eff[%] Chi2 N[It] | |=============================================================================| | VAMP2: Initialize new grids and write to file 'event_eff_2_p1.m1.vg2'. | VAMP2: set chain: use chained weights. 1 800 8.6787815E+01 1.63E-01 0.19 0.05* 33.31 2 800 8.7191410E+01 1.35E-01 0.16 0.04* 71.27 3 800 8.6999478E+01 1.34E-01 0.15 0.04* 43.40 |-----------------------------------------------------------------------------| 3 2400 8.7016142E+01 8.21E-02 0.09 0.05 43.40 1.83 3 |-----------------------------------------------------------------------------| 4 800 8.6940229E+01 1.23E-01 0.14 0.04* 69.34 5 800 8.6971432E+01 1.21E-01 0.14 0.04* 69.61 6 800 8.6821729E+01 1.26E-01 0.15 0.04 69.48 |-----------------------------------------------------------------------------| 6 2400 8.6913208E+01 7.12E-02 0.08 0.04 69.48 0.40 3 |=============================================================================| | Starting simulation for process 'event_eff_2_p1' | RNG: Initializing TAO random-number generator | RNG: Setting seed for random-number generator to 3 | Simulation: requested number of events = 1000 | corr. to luminosity [fb-1] = 1.1506E+01 | Events: writing to raw file 'event_eff_2_p1.evx' | Events: generating 1000 unweighted, unpolarized events ... | Events: event normalization mode '1' | ... event sample complete. | Events: actual unweighting efficiency = 71.33 % Warning: Encountered events with excess weight: 3 events ( 0.300 %) | Maximum excess weight = 2.209E-03 | Average excess weight = 5.217E-06 | Events: closing raw file 'event_eff_2_p1.evx' ?negative_weights = true | RNG: Initializing TAO random-number generator | RNG: Setting seed for random-number generator to 4 | Initializing integration for process event_eff_2_p1: | Beam structure: [any particles] | Beam data (collision): | e- (mass = 0.0000000E+00 GeV) | e+ (mass = 0.0000000E+00 GeV) | sqrts = 1.000000000000E+03 GeV | Phase space: generating configuration ... | Phase space: ... success. | Phase space: writing configuration file 'event_eff_2_p1.i1.phs' | ------------------------------------------------------------------------ | Process [scattering]: 'event_eff_2_p1' | Library name = 'event_eff_2_lib' | Process index = 1 | Process components: | 1: 'event_eff_2_p1_i1': e-, e+ => m-, m+ [omega] | ------------------------------------------------------------------------ | Phase space: 1 channels, 2 dimensions | Phase space: found 1 channel, collected in 1 grove. | Phase space: Using 1 equivalence between channels. | Phase space: wood Warning: No cuts have been defined. | Using user-defined reweighting factor. | Starting integration for process 'event_eff_2_p1' | Integrate: iterations = 3:1000:"g", 3:1000 | Integrator: 1 chains, 1 channels, 2 dimensions | Integrator: Using VAMP2 channel equivalences | Integrator: Write grid header and grids to 'event_eff_2_p1.m1.vg2' | Integrator: Grid checkpoint after each iteration | Integrator: 1000 initial calls, 20 max. bins, stratified = T | Integrator: VAMP2 |=============================================================================| | It Calls Integral[fb] Error[fb] Err[%] Acc Eff[%] Chi2 N[It] | |=============================================================================| | VAMP2: Initialize new grids and write to file 'event_eff_2_p1.m1.vg2'. | VAMP2: set chain: use chained weights. 1 800 -8.6707576E+01 1.62E-01 0.19 0.05* 33.99 2 800 -8.6718790E+01 1.29E-01 0.15 0.04* 73.41 3 800 -8.6811445E+01 1.23E-01 0.14 0.04* 53.74 |-----------------------------------------------------------------------------| 3 2400 -8.6753469E+01 7.79E-02 0.09 0.04 53.74 0.19 3 |-----------------------------------------------------------------------------| 4 800 -8.6868484E+01 1.17E-01 0.14 0.04* 63.54 5 800 -8.7088695E+01 1.20E-01 0.14 0.04 63.63 6 800 -8.6942541E+01 1.25E-01 0.14 0.04 63.64 |-----------------------------------------------------------------------------| 6 2400 -8.6965790E+01 6.95E-02 0.08 0.04 63.64 0.89 3 |=============================================================================| | Starting simulation for process 'event_eff_2_p1' | RNG: Initializing TAO random-number generator | RNG: Setting seed for random-number generator to 5 | Simulation: requested number of events = 1000 | corr. to luminosity [fb-1] = -1.1499E+01 | Events: writing to raw file 'event_eff_2_p1.evx' | Events: generating 1000 unweighted, unpolarized events ... | Events: event normalization mode '1' | ... event sample complete. -| Events: actual unweighting efficiency = 62.77 % +| Events: actual unweighting efficiency = 63.49 % +Warning: Encountered events with excess weight: 1 events ( 0.100 %) +| Maximum excess weight = 1.157E-03 +| Average excess weight = 1.157E-06 | Events: closing raw file 'event_eff_2_p1.evx' ?negative_weights = true | RNG: Initializing TAO random-number generator | RNG: Setting seed for random-number generator to 6 | Initializing integration for process event_eff_2_p1: | Beam structure: [any particles] | Beam data (collision): | e- (mass = 0.0000000E+00 GeV) | e+ (mass = 0.0000000E+00 GeV) | sqrts = 1.000000000000E+03 GeV | Phase space: generating configuration ... | Phase space: ... success. | Phase space: writing configuration file 'event_eff_2_p1.i1.phs' | ------------------------------------------------------------------------ | Process [scattering]: 'event_eff_2_p1' | Library name = 'event_eff_2_lib' | Process index = 1 | Process components: | 1: 'event_eff_2_p1_i1': e-, e+ => m-, m+ [omega] | ------------------------------------------------------------------------ | Phase space: 1 channels, 2 dimensions | Phase space: found 1 channel, collected in 1 grove. | Phase space: Using 1 equivalence between channels. | Phase space: wood Warning: No cuts have been defined. | Using user-defined reweighting factor. | Starting integration for process 'event_eff_2_p1' | Integrate: iterations = 3:1000:"g", 3:1000 | Integrator: 1 chains, 1 channels, 2 dimensions | Integrator: Using VAMP2 channel equivalences | Integrator: Write grid header and grids to 'event_eff_2_p1.m1.vg2' | Integrator: Grid checkpoint after each iteration | Integrator: 1000 initial calls, 20 max. bins, stratified = T | Integrator: VAMP2 |=============================================================================| | It Calls Integral[fb] Error[fb] Err[%] Acc Eff[%] Chi2 N[It] | |=============================================================================| | VAMP2: Initialize new grids and write to file 'event_eff_2_p1.m1.vg2'. | VAMP2: set chain: use chained weights. 1 800 -4.3608894E+01 1.58E-01 0.36 0.10* 29.56 2 800 -4.3548658E+01 1.44E-01 0.33 0.09* 62.98 3 800 -4.3438612E+01 1.37E-01 0.32 0.09* 37.73 |-----------------------------------------------------------------------------| 3 2400 -4.3524259E+01 8.42E-02 0.19 0.09 37.73 0.35 3 |-----------------------------------------------------------------------------| 4 800 -4.3242251E+01 1.34E-01 0.31 0.09* 61.67 5 800 -4.3484073E+01 1.34E-01 0.31 0.09* 62.04 6 800 -4.3359433E+01 1.24E-01 0.29 0.08* 62.24 |-----------------------------------------------------------------------------| 6 2400 -4.3361873E+01 7.55E-02 0.17 0.09 62.24 0.81 3 |=============================================================================| | Starting simulation for process 'event_eff_2_p1' | RNG: Initializing TAO random-number generator | RNG: Setting seed for random-number generator to 7 | Simulation: requested number of events = 1000 | corr. to luminosity [fb-1] = -2.3062E+01 | Events: writing to raw file 'event_eff_2_p1.evx' | Events: generating 1000 unweighted, unpolarized events ... | Events: event normalization mode '1' | ... event sample complete. -| Events: actual unweighting efficiency = 66.14 % +| Events: actual unweighting efficiency = 61.01 % +Warning: Encountered events with excess weight: 6 events ( 0.600 %) +| Maximum excess weight = 5.954E-03 +| Average excess weight = 1.334E-05 | Events: closing raw file 'event_eff_2_p1.evx' -| There were no errors and 6 warning(s). +| There were no errors and 8 warning(s). | WHIZARD run finished. |=============================================================================| Index: trunk/ChangeLog =================================================================== --- trunk/ChangeLog (revision 8827) +++ trunk/ChangeLog (revision 8828) @@ -1,2316 +1,2319 @@ ChangeLog -- Summary of changes to the WHIZARD package Use svn log to see detailed changes. Version 3.0.3+ +2022-04-20 + Bug fix for VAMP2 event generation with indefinite samples + ################################################################## 2022-04-06 RELEASE: version 3.0.3 2022-04-05 POWHEG matching for single flavor hadron collisions 2022-03-31 NLO EW processes with massless leptons and jets (i.e. jet clustering and photon recombination) supported NLO EW for massive initial leptons validated 2022-03-27 Complete implementation/validation of NLL electron PDFs 2022-02-22 Bug fix: correct normalization for CIRCE2+EPA+polarization 2022-02-21 WHIZARD core now uses Fortran modules and submodules 2022-01-27 Infrastructure for POWHEG matching for hadron collisions 2021-12-16 Event files can be written/read also for decay processes Implementation of running QED coupling alpha 2021-12-10 Independent variations of renormalization/factorization scale ################################################################## 2021-11-23 RELEASE: version 3.0.2 2021-11-19 Support for a wide class of mixed NLO QCD/EW processes 2021-11-18 Add pp processes for NLO EW corrections to testsuite 2021-11-11 Output numerically critical values with LCIO 2.17+ as double 2021-11-05 Minor refactoring on phase space points and kinematics 2021-10-21 NLO (QCD) differential distributions supported for full lepton collider setup: polarization, QED ISR, beamstrahlung 2021-10-15 SINDARIN now has a sum and product function of expressions, SINDARIN supports observables defined on full (sub)events First application: transverse mass Bug fix: 2HDM did not allow H+, H- as external particles 2021-10-14 CT18 PDFs included (NLO, NNLO) 2021-09-30 Bug fix: keep non-recombined photons in the event record 2021-09-13 Modular NLO event generation with real partition 2021-08-20 Bug fix: correctly reading in NLO fixed order events 2021-08-06 Generalize optional partitioning of the NLO real phase space ################################################################## 2021-07-08 RELEASE: version 3.0.1 2021-07-06 MPI parallelization now comes with two incarnations: - standard MPI parallelization ("simple", default) - MPI with load balancer ("load") 2021-07-05 Bug fix for C++17 default compilers w/ HepMC3/ROOT interface 2021-07-02 Improvement for POWHEG matching: - implement massless recoil case - enable reading in existing POWHEG grids - support kinematic cuts at generator level 2021-07-01 Distinguish different cases of photons in NLO EW corrections 2021-06-21 Option to keep negative PDF entries or set them zero 2021-05-31 Full LCIO MC production files can be properly recasted 2021-05-24 Use defaults for UFO models without propagators.py 2021-05-21 Bug fix: prevent invalid code for UFO models containing hyphens 2021-05-20 UFO files with scientific notation float constants allowed UFO files: max. n-arity of vertices bound by process multiplicity ################################################################## 2021-04-27 RELEASE: version 3.0.0 2021-04-20 Minimal required OCaml version is now 4.05.0. Bug fix for tau polarization from stau decays 2021-04-19 NLO EW splitting functions and collinear remnants completed Photon recombination implemented 2021-04-14 Bug fix for vertices/status codes with HepMC2/3 event format 2021-04-08 Correct Lorentz statistics for UFO model with Majorana fermions 2021-04-06 Bug fix for rare script failure in system_dependencies.f90.in Kappa factor for quartic Higgs coupling in SM_ac(_CKM) model 2021-04-04 Support for UFO extensions in SMEFTSim 3.0 2021-02-25 Enable VAMP and VAMP2 channel equivalences for NLO integrations 2021-02-04 Bug fix if user does not set a prefix at configuration 2020-12-10 Generalize NLO calculations to non-CMS lab frames 2020-12-08 Bug fix in expanded p-wave form factor for top threshold 2020-12-06 Patch for macOS Big Sur shared library handling due to libtool; the patch also demands gcc/gfortran 11.0/10.3/9.4/8.5 2020-12-04 O'Mega only inserts non-vanishing couplings from UFO models 2020-11-21 Bug fix for fractional hypercharges in UFO models 2020-11-11 Enable PYTHIA6 settings for eh collisions (enable-pythia6_eh) 2020-11-09 Correct flavor assignment for NLO fixed-order events 2020-11-05 Bug fix for ISR handler not working with unstable particles 2020-10-08 Bug fix in LHAPDF interface for photon PDFs 2020-10-07 Bug fix for structure function setup with asymmetric beams 2020-10-02 Python/Cython layer for WHIZARD API 2020-09-30 Allow mismatches of Python and name attributes in UFO models 2020-09-26 Support for negative PDG particles from certain UFO models 2020-09-24 Allow for QNUMBERS blocks in BSM SLHA files 2020-09-22 Full support for compilation with clang(++) on Darwin/macOS More documentation in the manual Minor clean-ups 2020-09-16 Bug fix enables reading LCIO events with LCIO v2.15+ ################################################################## 2020-09-16 RELEASE: version 2.8.5 2020-09-11 Bug fix for H->tau tau transverse polarization with PYTHIA6 (thanks to Junping Tian / Akiya Miyamoto) 2020-09-09 Fix a long standing bug (since 2.0) in the calculation of color factors when particles of different color were combined in a particle class. NB: O'Mega never produced a wrong number, it only declared all processes as invalid. 2020-09-08 Enable Openloops matrix element equivalences for optimization 2020-09-02 Compatibility fix for PYTHIA v8.301+ interface 2020-09-01 Support exclusive jet clustering in ee for Fastjet interface ################################################################## 2020-08-30 RELEASE: version 3.0.0_beta 2020-08-27 Major revision of NLO distributions and events for processes with structure functions: - Use parton momenta/flavors (instead of beams) for events - Bug fix for Lorentz boosts and Lorentz frames of momenta - Bug fix: apply cuts to virtual NLO component in correct frame - Correctly assign ISR radiation momenta in data structures - Refactoring on quantum numbers for NLO event data structures - Functional tests for hadron collider NLO distributions - many minor bug fixes regarding NLO hadron collider physics 2020-08-11 Bug fix for linking problem with OpenMPI 2020-08-07 New WHIZARD API: WHIZARD can be externally linked as a library, added examples for Fortran, C, C++ programs ################################################################## 2020-07-08 RELEASE: version 2.8.4 2020-07-07 Bug fix: steering of UFO Majorana models from WHIZARD ################################################################## 2020-07-06 Combined integration also for hadron collider processes at NLO 2020-07-05 Bug fix: correctly steer e+e- FastJet clustering algorithms Major revision of NLO differential distributions and events: - Correctly assign quantum numbers to NLO fixed-order events - Correctly assign weights to NLO fixed-order events for combined simulation - Cut all NLO fixed-order subevents in event groups individually - Only allow "sigma" normalization for NLO fixed-order events - Use correct PDF setup for NLO counter events - Several technical fixes and updates of the NLO testsuite ################################################################## 2020-07-03 RELEASE: version 2.8.3 2020-07-02 Feature-complete UFO implementation for Majorana fermions 2020-06-22 Running width scheme supported for O'Mega matrix elements 2020-06-20 Adding H-s-s coupling to SM_Higgs(_CKM) models 2020-06-17 Completion of ILC 2->6 fermion extended test suite 2020-06-15 Bug fix: PYTHIA6/Tauola, correctly assign tau spins for stau decays 2020-06-09 Bug fix: correctly update calls for additional VAMP/2 iterations Bug fix: correct assignment for tau spins from PYTHIA6 interface 2020-06-04 Bug fix: cascades2 tree merge with empty subtree(s) 2020-05-31 Switch $epa_mode for different EPA implementations 2020-05-26 Bug fix: spin information transferred for resonance histories 2020-04-13 HepMC: correct weighted events for non-xsec event normalizations 2020-04-04 Improved HepMC3 interface: HepMC3 Root/RootTree interface 2020-03-24 ISR: Fix on-shell kinematics for events with ?isr_handler=true (set ?isr_handler_keep_mass=false for old behavior) 2020-03-11 Beam masses are correctly passed to hard matrix element for CIRCE2 EPA with polarized beams: double-counting corrected ################################################################## 2020-03-03 RELEASE: version 3.0.0_alpha 2020-02-25 Bug fix: Scale and alphas can be retrieved from internal event format to external formats 2020-02-17 Bug fix: ?keep_failed_events now forces output of actual event data Bug fix: particle-set reconstruction (rescanning events w/o radiation) 2020-01-28 Bug fix for left-over EPA parameter epa_e_max (replaced by epa_q_max) 2020-01-23 Bug fix for real components of NLO QCD 2->1 processes 2020-01-22 Bug fix: correct random number sequencing during parallel MPI event generation with rng_stream 2020-01-21 Consistent distribution of events during parallel MPI event generation 2020-01-20 Bug fix for configure setup for automake v1.16+ 2020-01-18 General SLHA parameter files for UFO models supported 2020-01-08 Bug fix: correctly register RECOLA processes with flavor sums 2019-12-19 Support for UFO customized propagators O'Mega unit tests for fermion-number violating interactions 2019-12-10 For distribution building: check for graphviz/dot version 2.40 or newer 2019-11-21 Bug fix: alternate setups now work correctly Infrastructure for accessing alpha_QED event-by-event Guard against tiny numbers that break ASCII event output Enable inverse hyperbolic functions as SINDARIN observables Remove old compiler bug workarounds 2019-11-20 Allow quoted -e argument, implemented -f option 2019-11-19 Bug fix: resonance histories now work also with UFO models Fix in numerical precision of ASCII VAMP2 grids 2019-11-06 Add squared matrix elements to the LCIO event header 2019-11-05 Do not include RNG state in MD5 sum for CIRCE1/2 2019-11-04 Full CIRCE2 ILC 250 and 500 GeV beam spectra added Minor update on LCIO event header information 2019-10-30 NLO QCD for final states completed When using Openloops, v2.1.1+ mandatory 2019-10-25 Binary grid files for VAMP2 integrator ################################################################## 2019-10-24 RELEASE: version 2.8.2 2019-10-20 Bug fix for HepMC linker flags 2019-10-19 Support for spin-2 particles from UFO files 2019-09-27 LCIO event format allows rescan and alternate weights 2019-09-24 Compatibility fix for OCaml v4.08.0+ ################################################################## 2019-09-21 RELEASE: version 2.8.1 2019-09-19 Carriage return characters in UFO models can be parsed Mathematica symbols in UFO models possible Unused/undefined parameters in UFO models handled 2019-09-13 New extended NLO test suite for ee and pp processes 2019-09-09 Photon isolation (separation of perturbative and fragmentation part a la Frixione) 2019-09-05 Major progress on NLO QCD for hadron collisions: - correctly assign flavor structures for alpha regions - fix crossing of particles for initial state splittings - correct assignment for PDF factors for real subtractions - fix kinematics for collinear splittings - bug fix for integrated virtual subtraction terms 2019-09-03 b and c jet selection in cuts and analysis 2019-08-27 Support for Intel MPI 2019-08-20 Complete (preliminary) HepMC3 support (incl. backwards HepMC2 write/read mode) 2019-08-08 Bug fix: handle carriage returns in UFO files (non-Unix OS) ################################################################## 2019-08-07 RELEASE: version 2.8.0 2019-07-31 Complete WHIZARD UFO interface: - general Lorentz structures - matrix element support for general color factors - missing features: Majorana fermions and SLHA 2019-07-20 Make WHIZARD compatible with OCaml 4.08.0+ 2019-07-19 Fix version testing for LHAPDF 6.2.3 and newer Minimal required OCaml version is now 4.02.3. 2019-04-18 Correctly generate ordered FKS tuples for alpha regions from all possible underlying Born processes 2019-04-08 Extended O'Mega/Recola matrix element test suite 2019-03-29 Correct identical particle symmetry factors for FKS subtraction 2019-03-28 Correct assertion of spin-correlated matrix elements for hadron collisions 2019-03-27 Bug fix for cut-off parameter delta_i for collinear plus/minus regions ################################################################## 2019-03-27 RELEASE: version 2.7.1 2019-02-19 Further infrastructure for HepMC3 interface (v3.01.00) 2019-02-07 Explicit configure option for using debugging options Bug fix for performance by removing unnecessary debug operations 2019-01-29 Bug fix for DGLAP remnants with cut-off parameter delta_i 2019-01-24 Radiative decay neu2 -> neu1 A added to MSSM_Hgg model ################################################################## 2019-01-21 RELEASE: version 2.7.0 2018-12-18 Support RECOLA for integrated und unintegrated subtractions 2018-12-11 FCNC top-up sector in model SM_top_anom 2018-12-05 Use libtirpc instead of SunRPC on Arch Linux etc. 2018-11-30 Display rescaling factor for weighted event samples with cuts 2018-11-29 Reintroduce check against different masses in flavor sums Bug fix for wrong couplings in the Littlest Higgs model(s) 2018-11-22 Bug fix for rescanning events with beam structure 2018-11-09 Major refactoring of internal process data 2018-11-02 PYTHIA8 interface 2018-10-29 Flat phase space parametrization with RAMBO (on diet) implemented 2018-10-17 Revise extended test suite 2018-09-27 Process container for RECOLA processes 2018-09-15 Fixes by M. Berggren for PYTHIA6 interface 2018-09-14 First fixes after HepForge modernization ################################################################## 2018-08-23 RELEASE: version 2.6.4 2018-08-09 Infrastructure to check colored subevents 2018-07-10 Infrastructure for running WHIZARD in batch mode 2018-07-04 MPI available from distribution tarball 2018-06-03 Support Intel Fortran Compiler under MAC OS X 2018-05-07 FKS slicing parameter delta_i (initial state) implementend 2018-05-03 Refactor structure function assignment for NLO 2018-05-02 FKS slicing parameter xi_cut, delta_0 implemented 2018-04-20 Workspace subdirectory for process integration (grid/phs files) Packing/unpacking of files at job end/start Exporting integration results from scan loops 2018-04-13 Extended QCD NLO test suite 2018-04-09 Bug fix for Higgs Singlet Extension model 2018-04-06 Workspace subdirectory for process generation and compilation --job-id option for creating job-specific names 2018-03-20 Bug fix for color flow matching in hadron collisions with identical initial state quarks 2018-03-08 Structure functions quantum numbers correctly assigned for NLO 2018-02-24 Configure setup includes 'pgfortran' and 'flang' 2018-02-21 Include spin-correlated matrix elements in interactions 2018-02-15 Separate module for QED ISR structure functions ################################################################## 2018-02-10 RELEASE: version 2.6.3 2018-02-08 Improvements in memory management for PS generation 2018-01-31 Partial refactoring: quantum number assigment NLO Initial-state QCD splittings for hadron collisions 2018-01-25 Bug fix for weighted events with VAMP2 2018-01-17 Generalized interface for Recola versions 1.3+ and 2.1+ 2018-01-15 Channel equivalences also for VAMP2 integrator 2018-01-12 Fix for OCaml compiler 4.06 (and newer) 2017-12-19 RECOLA matrix elements with flavor sums can be integrated 2017-12-18 Bug fix for segmentation fault in empty resonance histories 2017-12-16 Fixing a bug in PYTHIA6 PYHEPC routine by omitting CMShowers from transferral between PYTHIA and WHIZARD event records 2017-12-15 Event index for multiple processes in event file correct ################################################################## 2017-12-13 RELEASE: version 2.6.2 2017-12-07 User can set offset in event numbers 2017-11-29 Possibility to have more than one RECOLA process in one file 2017-11-23 Transversal/mixed (and unitarized) dim-8 operators 2017-11-16 epa_q_max replaces epa_e_max (trivial factor 2) 2017-11-15 O'Mega matrix element compilation silent now 2017-11-14 Complete expanded P-wave form factor for top threshold 2017-11-10 Incoming particles can be accessed in SINDARIN 2017-11-08 Improved handling of resonance insertion, additional parameters 2017-11-04 Added Higgs-electron coupling (SM_Higgs) ################################################################## 2017-11-03 RELEASE: version 2.6.1 2017-10-20 More than 5 NLO components possible at same time 2017-10-19 Gaussian cutoff for shower resonance matching 2017-10-12 Alternative (more efficient) method to generate phase space file 2017-10-11 Bug fix for shower resonance histories for processes with multiple components 2017-09-25 Bug fix for process libraries in shower resonance histories 2017-09-21 Correctly generate pT distribution for EPA remnants 2017-09-20 Set branching ratios for unstable particles also by hand 2017-09-14 Correctly generate pT distribution for ISR photons ################################################################## 2017-09-08 RELEASE: version 2.6.0 2017-09-05 Bug fix for initial state NLO QCD flavor structures Real and virtual NLO QCD hadron collider processes work with internal interactions 2017-09-04 Fully validated MPI integration and event generation 2017-09-01 Resonance histories for shower: full support Bug fix in O'Mega model constraints O'Mega allows to output a parsable form of the DAG 2017-08-24 Resonance histories in events for transferral to parton shower (e.g. in ee -> jjjj) 2017-08-01 Alpha version of HepMC v3 interface (not yet really functional) 2017-07-31 Beta version for RECOLA OLP support 2017-07-06 Radiation generator fix for LHC processes 2017-06-30 Fix bug for NLO with structure functions and/or polarization 2017-06-23 Collinear limit for QED corrections works 2017-06-17 POWHEG grids generated already during integration 2017-06-12 Soft limit for QED corrections works 2017-05-16 Beta version of full MPI parallelization (VAMP2) Check consistency of POWHEG grid files Logfile config-summary.log for configure summary 2017-05-12 Allow polarization in top threshold 2017-05-09 Minimal demand automake 1.12.2 Silent rules for make procedures 2017-05-07 Major fix for POWHEG damping Correctly initialize FKS ISR phasespace ################################################################## 2017-05-06 RELEASE: version 2.5.0 2017-05-05 Full UFO support (SM-like models) Fixed-beam ISR FKS phase space 2017-04-26 QED splittings in radiation generator 2017-04-10 Retire deprecated O'Mega vertex cache files ################################################################## 2017-03-24 RELEASE: version 2.4.1 2017-03-16 Distinguish resonance charge in phase space channels Keep track of resonance histories in phase space Complex mass scheme default for OpenLoops amplitudes 2017-03-13 Fix helicities for polarized OpenLoops calculations 2017-03-09 Possibility to advance RNG state in rng_stream 2017-03-04 General setup for partitioning real emission phase space 2017-03-06 Bug fix on rescan command for converting event files 2017-02-27 Alternative multi-channel VEGAS implementation VAMP2: serial backbone for MPI setup Smoothstep top threshold matching 2017-02-25 Single-beam structure function with s-channel mapping supported Safeguard against invalid process libraries 2017-02-16 Radiation generator for photon emission 2017-02-10 Fixes for NLO QCD processes (color correlations) 2017-01-16 LCIO variable takes precedence over LCIO_DIR 2017-01-13 Alternative random number generator rng_stream (cf. L'Ecuyer et al.) 2017-01-01 Fix for multi-flavor BLHA tree matrix elements 2016-12-31 Grid path option for VAMP grids 2016-12-28 Alpha version of Recola OLP support 2016-12-27 Dalitz plots for FKS phase space 2016-12-14 NLO multi-flavor events possible 2016-12-09 LCIO event header information added 2016-12-02 Alpha version of RECOLA interface Bug fix for generator status in LCIO ################################################################## 2016-11-28 RELEASE: version 2.4.0 2016-11-24 Bug fix for OpenLoops interface: EW scheme is set by WHIZARD Bug fixes for top threshold implementation 2016-11-11 Refactoring of dispatching 2016-10-18 Bug fix for LCIO output 2016-10-10 First implementation for collinear soft terms 2016-10-06 First full WHIZARD models from UFO files 2016-10-05 WHIZARD does not support legacy gcc 4.7.4 any longer 2016-09-30 Major refactoring of process core and NLO components 2016-09-23 WHIZARD homogeneous entity: discarding subconfigures for CIRCE1/2, O'Mega, VAMP subpackages; these are reconstructable by script projectors 2016-09-06 Introduce main configure summary 2016-08-26 Fix memory leak in event generation ################################################################## 2016-08-25 RELEASE: version 2.3.1 2016-08-19 Bug fix for EW-scheme dependence of gluino propagators 2016-08-01 Beta version of complex mass scheme support 2016-07-26 Fix bug in POWHEG damping for the matching ################################################################## 2016-07-21 RELEASE: version 2.3.0 2016-07-20 UFO file support (alpha version) in O'Mega 2016-07-13 New (more) stable of WHIZARD GUI Support for EW schemes for OpenLoops Factorized NLO top decays for threshold model 2016-06-15 Passing factorization scale to PYTHIA6 Adding charge and neutral observables 2016-06-14 Correcting angular distribution/tweaked kinematics in non-collinear structure functions splittings 2016-05-10 Include (Fortran) TAUOLA/PHOTOS for tau decays via PYTHIA6 (backwards validation of LC CDR/TDR samples) 2016-04-27 Within OpenLoops virtuals: support for Collier library 2016-04-25 O'Mega vertex tables only loaded at first usage 2016-04-21 New CJ15 PDF parameterizations added 2016-04-21 Support for hadron collisions at NLO QCD 2016-04-05 Support for different (parameter) schemes in model files 2016-03-31 Correct transferral of lifetime/vertex from PYTHIA/TAUOLA into the event record 2016-03-21 New internal implementation of polarization via Bloch vectors, remove pointer constructions 2016-03-13 Extension of cascade syntax for processes: exclude propagators/vertices etc. possible 2016-02-24 Full support for OpenLoops QCD NLO matrix elements, inclusion in test suite 2016-02-12 Substantial progress on QCD NLO support 2016-02-02 Automated resonance mapping for FKS subtraction 2015-12-17 New BSM model WZW for diphoton resonances ################################################################## 2015-11-22 RELEASE: version 2.2.8 2015-11-21 Bug fix for fixed-order NLO events 2015-11-20 Anomalous FCNC top-charm vertices 2015-11-19 StdHEP output via HEPEVT/HEPEV4 supported 2015-11-18 Full set of electroweak dim-6 operators included 2015-10-22 Polarized one-loop amplitudes supported 2015-10-21 Fixes for event formats for showered events 2015-10-14 Callback mechanism for event output 2015-09-22 Bypass matrix elements in pure event sample rescans StdHep frozen final version v5.06.01 included internally 2015-09-21 configure option --with-precision to demand 64bit, 80bit, or 128bit Fortran and bind C precision types 2015-09-07 More extensive tests of NLO infrastructure and POWHEG matching 2015-09-01 NLO decay infrastructure User-defined squared matrix elements Inclusive FastJet algorithm plugin Numerical improvement for small boosts ################################################################## 2015-08-11 RELEASE: version 2.2.7 2015-08-10 Infrastructure for damped POWHEG Massive emitters in POWHEG Born matrix elements via BLHA GoSam filters via SINDARIN Minor running coupling bug fixes Fixed-order NLO events 2015-08-06 CT14 PDFs included (LO, NLO, NNLL) 2015-07-07 Revalidation of ILC WHIZARD-PYTHIA event chain Extended test suite for showered events Alpha version of massive FSR for POWHEG 2015-06-09 Fix memory leak in interaction for long cascades Catch mismatch between beam definition and CIRCE2 spectrum 2015-06-08 Automated POWHEG matching: beta version Infrastructure for GKS matching Alpha version of fixed-order NLO events CIRCE2 polarization averaged spectra with explicitly polarized beams 2015-05-12 Abstract matching type: OO structure for matching/merging 2015-05-07 Bug fix in event record WHIZARD-PYTHIA6 transferral Gaussian beam spectra for lepton colliders ################################################################## 2015-05-02 RELEASE: version 2.2.6 2015-05-01 Models for (unitarized) tensor resonances in VBS 2015-04-28 Bug fix in channel weights for event generation. 2015-04-18 Improved event record transfer WHIZARD/PYTHIA6 2015-03-19 POWHEG matching: alpha version ################################################################## 2015-02-27 RELEASE: version 2.2.5 2015-02-26 Abstract types for quantum numbers 2015-02-25 Read-in of StdHEP events, self-tests 2015-02-22 Bug fix for mother-daughter relations in showered/hadronized events 2015-02-20 Projection on polarization in intermediate states 2015-02-13 Correct treatment of beam remnants in event formats (also LC remnants) ################################################################## 2015-02-06 RELEASE: version 2.2.4 2015-02-06 Bug fix in event output 2015-02-05 LCIO event format supported 2015-01-30 Including state matrices in WHIZARD's internal IO Versioning for WHIZARD's internal IO Libtool update from 2.4.3 to 2.4.5 LCIO event output (beta version) 2015-01-27 Progress on NLO integration Fixing a bug for multiple processes in a single event file when using beam event files 2015-01-19 Bug fix for spin correlations evaluated in the rest frame of the mother particle 2015-01-17 Regression fix for statically linked processes from SARAH and FeynRules 2015-01-10 NLO: massive FKS emitters supported (experimental) 2015-01-06 MMHT2014 PDF sets included 2015-01-05 Handling mass degeneracies in auto_decays 2014-12-19 Fixing bug in rescan of event files ################################################################## 2014-11-30 RELEASE: version 2.2.3 2014-11-29 Beta version of LO continuum/NLL-threshold matched top threshold model for e+e- physics 2014-11-28 More internal refactoring: disentanglement of module dependencies 2014-11-21 OVM: O'Mega Virtual Machine, bytecode instructions instead of compiled Fortran code 2014-11-01 Higgs Singlet extension model included 2014-10-18 Internal restructuring of code; half-way WHIZARD main code file disassembled 2014-07-09 Alpha version of NLO infrastructure ################################################################## 2014-07-06 RELEASE: version 2.2.2 2014-07-05 CIRCE2: correlated LC beam spectra and GuineaPig Interface to LC machine parameters 2014-07-01 Reading LHEF for decayed/factorized/showered/ hadronized events 2014-06-25 Configure support for GoSAM/Ninja/Form/QGraf 2014-06-22 LHAPDF6 interface 2014-06-18 Module for automatic generation of radiation and loop infrastructure code 2014-06-11 Improved internal directory structure ################################################################## 2014-06-03 RELEASE: version 2.2.1 2014-05-30 Extensions of internal PDG arrays 2014-05-26 FastJet interface 2014-05-24 CJ12 PDFs included 2014-05-20 Regression fix for external models (via SARAH or FeynRules) ################################################################## 2014-05-18 RELEASE: version 2.2.0 2014-04-11 Multiple components: inclusive process definitions, syntax: process A + B + ... 2014-03-13 Improved PS mappings for e+e- ISR ILC TDR and CLIC spectra included in CIRCE1 2014-02-23 New models: AltH w\ Higgs for exclusion purposes, SM_rx for Dim 6-/Dim-8 operators, SSC for general strong interactions (w/ Higgs), and NoH_rx (w\ Higgs) 2014-02-14 Improved s-channel mapping, new on-shell production mapping (e.g. Drell-Yan) 2014-02-03 PRE-RELEASE: version 2.2.0_beta 2014-01-26 O'Mega: Feynman diagram generation possible (again) 2013-12-16 HOPPET interface for b parton matching 2013-11-15 PRE-RELEASE: version 2.2.0_alpha-4 2013-10-27 LHEF standards 1.0/2.0/3.0 implemented 2013-10-15 PRE-RELEASE: version 2.2.0_alpha-3 2013-10-02 PRE-RELEASE: version 2.2.0_alpha-2 2013-09-25 PRE-RELEASE: version 2.2.0_alpha-1 2013-09-12 PRE-RELEASE: version 2.2.0_alpha 2013-09-03 General 2HDM implemented 2013-08-18 Rescanning/recalculating events 2013-06-07 Reconstruction of complete event from 4-momenta possible 2013-05-06 Process library stacks 2013-05-02 Process stacks 2013-04-29 Single-particle phase space module 2013-04-26 Abstract interface for random number generator 2013-04-24 More object-orientation on modules Midpoint-rule integrator 2013-04-05 Object-oriented integration and event generation 2013-03-12 Processes recasted object-oriented: MEs, scales, structure functions First infrastructure for general Lorentz structures 2013-01-17 Object-orientated reworking of library and process core, more variable internal structure, unit tests 2012-12-14 Update Pythia version to 6.4.27 2012-12-04 Fix the phase in HAZ vertices 2012-11-21 First O'Mega unit tests, some infrastructure 2012-11-13 Bug fix in anom. HVV Lorentz structures ################################################################## 2012-09-18 RELEASE: version 2.1.1 2012-09-11 Model MSSM_Hgg with Hgg and HAA vertices 2012-09-10 First version of implementation of multiple interactions in WHIZARD 2012-09-05 Infrastructure for internal CKKW matching 2012-09-02 C, C++, Python API 2012-07-19 Fixing particle numbering in HepMC format ################################################################## 2012-06-15 RELEASE: version 2.1.0 2012-06-14 Analytical and kT-ordered shower officially released PYTHIA interface officially released 2012-05-09 Intrisince PDFs can be used for showering 2012-05-04 Anomalous Higgs couplings a la hep-ph/9902321 ################################################################## 2012-03-19 RELEASE: version 2.0.7 2012-03-15 Run IDs are available now More event variables in analysis Modified raw event format (compatibility mode exists) 2012-03-12 Bug fix in decay-integration order MLM matching steered completely internally now 2012-03-09 Special phase space mapping for narrow resonances decaying to 4-particle final states with far off-shell intermediate states Running alphas from PDF collaborations with builtin PDFs 2012-02-16 Bug fix in cascades decay infrastructure 2012-02-04 WHIZARD documentation compatible with TeXLive 2011 2012-02-01 Bug fix in FeynRules interface with --prefix flag 2012-01-29 Bug fix with name clash of O'Mega variable names 2012-01-27 Update internal PYTHIA to version 6.4.26 Bug fix in LHEF output 2012-01-21 Catching stricter automake 1.11.2 rules 2011-12-23 Bug fix in decay cascade setup 2011-12-20 Bug fix in helicity selection rules 2011-12-16 Accuracy goal reimplemented 2011-12-14 WHIZARD compatible with TeXLive 2011 2011-12-09 Option --user-target added ################################################################## 2011-12-07 RELEASE: version 2.0.6 2011-12-07 Bug fixes in SM_top_anom Added missing entries to HepMC format 2011-12-06 Allow to pass options to O'Mega Bug fix for HEPEVT block for showered/hadronized events 2011-12-01 Reenabled user plug-in for external code for cuts, structure functions, routines etc. 2011-11-29 Changed model SM_Higgs for Higgs phenomenology 2011-11-25 Supporting a Y, (B-L) Z' model 2011-11-23 Make WHIZARD compatible for MAC OS X Lion/XCode 4 2011-09-25 WHIZARD paper published: Eur.Phys.J. C71 (2011) 1742 2011-08-16 Model SM_QCD: QCD with one EW insertion 2011-07-19 Explicit output channel for dvips avoids printing 2011-07-10 Test suite for WHIZARD unit tests 2011-07-01 Commands for matrix element tests More OpenMP parallelization of kinematics Added unit tests 2011-06-23 Conversion of CIRCE2 from F77 to F90, major clean-up 2011-06-14 Conversion of CIRCE1 from F77 to F90 2011-06-10 OpenMP parallelization of channel kinematics (by Matthias Trudewind) 2011-05-31 RELEASE: version 1.97 2011-05-24 Minor bug fixes: update grids and elsif statement. ################################################################## 2011-05-10 RELEASE: version 2.0.5 2011-05-09 Fixed bug in final state flavor sums Minor improvements on phase-space setup 2011-05-05 Minor bug fixes 2011-04-15 WHIZARD as a precompiled 64-bit binary available 2011-04-06 Wall clock instead of cpu time for time estimates 2011-04-05 Major improvement on the phase space setup 2011-04-02 OpenMP parallelization for helicity loop in O'Mega matrix elements 2011-03-31 Tools for relocating WHIZARD and use in batch environments 2011-03-29 Completely static builds possible, profiling options 2011-03-28 Visualization of integration history 2011-03-27 Fixed broken K-matrix implementation 2011-03-23 Including the GAMELAN manual in the distribution 2011-01-26 WHIZARD analysis can handle hadronized event files 2011-01-17 MSTW2008 and CT10 PDF sets included 2010-12-23 Inclusion of NMSSM with Hgg couplings 2010-12-21 Advanced options for integration passes 2010-11-16 WHIZARD supports CTEQ6 and possibly other PDFs directly; data files included in the distribution ################################################################## 2010-10-26 RELEASE: version 2.0.4 2010-10-06 Bug fix in MSSM implementation 2010-10-01 Update to libtool 2.4 2010-09-29 Support for anomalous top couplings (form factors etc.) Bug fix for running gauge Yukawa SUSY couplings 2010-09-28 RELEASE: version 1.96 2010-09-21 Beam remnants and pT spectra for lepton collider re-enabled Restructuring subevt class 2010-09-16 Shower and matching are disabled by default PYTHIA as a conditional on these two options 2010-09-14 Possibility to read in beam spectra re-enabled (e.g. Guinea Pig) 2010-09-13 Energy scan as (pseudo-) structure functions re-implemented 2010-09-10 CIRCE2 included again in WHIZARD 2 and validated 2010-09-02 Re-implementation of asymmetric beam energies and collision angles, e-p collisions work, inclusion of a HERA DIS test case ################################################################## 2010-10-18 RELEASE: version 2.0.3 2010-08-08 Bug in CP-violating anomalous triple TGCs fixed 2010-08-06 Solving backwards compatibility problem with O'Caml 3.12.0 2010-07-12 Conserved quantum numbers speed up O'Mega code generation 2010-07-07 Attaching full ISR/FSR parton shower and MPI/ISR module Added SM model containing Hgg, HAA, HAZ vertices 2010-07-02 Matching output available as LHEF and STDHEP 2010-06-30 Various bug fixes, missing files, typos 2010-06-26 CIRCE1 completely re-enabled Chaining structure functions supported 2010-06-25 Partial support for conserved quantum numbers in O'Mega 2010-06-21 Major upgrade of the graphics package: error bars, smarter SINDARIN steering, documentation, and all that... 2010-06-17 MLM matching with PYTHIA shower included 2010-06-16 Added full CIRCE1 and CIRCE2 versions including full documentation and miscellanea to the trunk 2010-06-12 User file management supported, improved variable and command structure 2010-05-24 Improved handling of variables in local command lists 2010-05-20 PYTHIA interface re-enabled 2010-05-19 ASCII file formats for interfacing ROOT and gnuplot in data analysis ################################################################## 2010-05-18 RELEASE: version 2.0.2 2010-05-14 Reimplementation of visualization of phase space channels Minor bug fixes 2010-05-12 Improved phase space - elimination of redundancies 2010-05-08 Interface for polarization completed: polarized beams etc. 2010-05-06 Full quantum numbers appear in process log Integration results are usable as user variables Communication with external programs 2010-05-05 Split module commands into commands, integration, simulation modules 2010-05-04 FSR+ISR for the first time connected to the WHIZARD 2 core ################################################################## 2010-04-25 RELEASE: version 2.0.1 2010-04-23 Automatic compile and integrate if simulate is called Minor bug fixes in O'Mega 2010-04-21 Checkpointing for event generation Flush statements to use WHIZARD inside a pipe 2010-04-20 Reimplementation of signal handling in WGIZARD 2.0 2010-04-19 VAMP is now a separately configurable and installable unit of WHIZARD, included VAMP self-checks Support again compilation in quadruple precision 2010-04-06 Allow for logarithmic plots in GAMELAN, reimplement the possibility to set the number of bins 2010-04-15 Improvement on time estimates for event generation ################################################################## 2010-04-12 RELEASE: version 2.0.0 2010-04-09 Per default, the code for the amplitudes is subdivided to allow faster compiler optimization More advanced and unified and straightforward command language syntax Final bug fixes 2010-04-07 Improvement on SINDARIN syntax; printf, sprintf function thorugh a C interface 2010-04-05 Colorizing DAGs instead of model vertices: speed boost in colored code generation 2010-03-31 Generalized options for normalization of weighted and unweighted events Grid and weight histories added again to log files Weights can be used in analyses 2010-03-28 Cascade decays completely implemented including color and spin correlations 2010-03-07 Added new WHIZARD header with logo 2010-03-05 Removed conflict in O'Mega amplitudes between flavour sums and cascades StdHEP interface re-implemented 2010-03-03 RELEASE: version 2.0.0rc3 Several bug fixes for preventing abuse in input files OpenMP support for amplitudes Reimplementation of WHIZARD 1 HEPEVT ASCII event formats FeynRules interface successfully passed MSSM test 2010-02-26 Eliminating ghost gluons from multi-gluon amplitudes 2010-02-25 RELEASE: version 1.95 HEPEVT format from WHIZARD 1 re-implemented in WHIZARD 2 2010-02-23 Running alpha_s implemented in the FeynRules interface 2010-02-19 MSSM (semi-) automatized self-tests finalized 2010-02-17 RELEASE: version 1.94 2010-02-16 Closed memory corruption in WHIZARD 1 Fixed problems of old MadGraph and CompHep drivers with modern compilers Uncolored vertex selection rules for colored amplitudes in O'Mega 2010-02-15 Infrastructure for color correlation computation in O'Mega finished Forbidden processes are warned about, but treated as non-fatal 2010-02-14 Color correlation computation in O'Mega finalized 2010-02-10 Improving phase space mappings for identical particles in initial and final states Introduction of more extended multi-line error message 2010-02-08 First O'Caml code for computation of color correlations in O'Mega 2010-02-07 First MLM matching with e+ e- -> jets ################################################################## 2010-02-06 RELEASE: version 2.0.0rc2 2010-02-05 Reconsidered the Makefile structure and more extended tests Catch a crash between WHIZARD and O'Mega for forbidden processes Tensor products of arbitrary color structures in jet definitions 2010-02-04 Color correlation computation in O'Mega finalized ################################################################## 2010-02-03 RELEASE: version 2.0.0rc1 ################################################################## 2010-01-31 Reimplemented numerical helicity selection rules Phase space functionality of version 1 restored and improved 2009-12-05 NMSSM validated with FeynRules in WHIZARD 1 (Felix Braam) 2009-12-04 RELEASE: version 2.0.0alpha ################################################################## 2009-04-16 RELEASE: version 1.93 2009-04-15 Clean-up of Makefiles and configure scripts Reconfiguration of BSM model implementation extended supersymmetric models 2008-12-23 New model NMSSM (Felix Braam) SLHA2 added Bug in LHAPDF interface fixed 2008-08-16 Bug fixed in K matrix implementation Gravitino option in the MSSM added 2008-03-20 Improved color and flavor sums ################################################################## 2008-03-12 RELEASE: version 1.92 LHEF (Les Houches Event File) format added Fortran 2003 command-line interface (if supported by the compiler) Automated interface to colored models More bug fixes and workarounds for compiler compatibility ################################################################## 2008-03-06 RELEASE: version 1.91 New model K-matrix (resonances and anom. couplings in WW scattering) EWA spectrum Energy-scan pseudo spectrum Preliminary parton shower module (only from final-state quarks) Cleanup and improvements of configure process Improvements for O'Mega parameter files Quadruple precision works again More plotting options: lines, symbols, errors Documentation with PDF bookmarks enabled Various bug fixes 2007-11-29 New model UED ################################################################## 2007-11-23 RELEASE: version 1.90 O'Mega now part of the WHIZARD tree Madgraph/CompHEP disabled by default (but still usable) Support for LHAPDF (preliminary) Added new models: SMZprime, SM_km, Template Improved compiler recognition and compatibility Minor bug fixes ################################################################## 2006-06-15 RELEASE: version 1.51 Support for anomaly-type Higgs couplings (to gluon and photon/Z) Support for spin 3/2 and spin 2 New models: Little Higgs (4 versions), toy models for extra dimensions and gravitinos Fixes to the whizard.nw source documentation to run through LaTeX Intel 9.0 bug workaround (deallocation of some arrays) 2006-05-15 O'Mega RELEASE: version 0.11 merged JRR's O'Mega extensions ################################################################## 2006-02-07 RELEASE: version 1.50 To avoid confusion: Mention outdated manual example in BUGS file O'Mega becomes part of the WHIZARD generator 2006-02-02 [bug fix update] Bug fix: spurious error when writing event files for weighted events Bug fix: 'r' option for omega produced garbage for some particle names Workaround for ifort90 bug (crash when compiling whizard_event) Workaround for ifort90 bug (crash when compiling hepevt_common) 2006-01-27 Added process definition files for MSSM 2->2 processes Included beam recoil for EPA (T.Barklow) Updated STDHEP byte counts (for STDHEP 5.04.02) Fixed STDHEP compatibility (avoid linking of incomplete .so libs) Fixed issue with comphep requiring Xlibs on Opteron Fixed issue with ifort 8.x on Opteron (compiling 'signal' interface) Fixed color-flow code: was broken for omega with option 'c' and 'w' Workaround hacks for g95 compatibility 2005-11-07 O'Mega RELEASE: version 0.10 O'Mega, merged JRR's and WK's color hack for WHiZard O'Mega, EXPERIMENTAL: cache fusion tables (required for colors a la JRR/WK) O'Mega, make JRR's MSSM official ################################################################## 2005-10-25 RELEASE: version 1.43 Minor fixes in MSSM couplings (Higgs/3rd gen squarks). This should be final, since the MSSM results agree now completely with Madgraph and Sherpa User-defined lower and upper limits for split event file count Allow for counters (events, bytes) exceeding $2^{31}$ Revised checksum treatment and implementation (now MD5) Bug fix: missing process energy scale in raw event file ################################################################## 2005-09-30 RELEASE: version 1.42 Graphical display of integration history ('make history') Allow for switching off signals even if supported (configure option) 2005-09-29 Revised phase space generation code, in particular for flavor sums Negative cut and histogram codes use initial beams instead of initial parton momenta. This allows for computing, e.g., E_miss Support constant-width and zero-width options for O'Mega Width options now denoted by w:X (X=f,c,z). f option obsolescent Bug fix: colorized code: flipped indices could screw up result Bug fix: O'Mega with 'c' and 'w:f' option together (still some problem) Bug fix: dvips on systems where dvips defaults to lpr Bug fix: integer overflow if too many events are requested 2005-07-29 Allow for 2 -> 1 processes (if structure functions are on) 2005-07-26 Fixed and expanded the 'test' matrix element: Unit matrix element with option 'u' / default: normalized phase space ################################################################## 2005-07-15 RELEASE: version 1.41 Bug fix: no result for particle decay processes with width=0 Bug fix: line breaks in O'Mega files with color decomposition 2005-06-02 New self-tests (make test-QED / test-QCD / test-SM) check lists of 2->2 processes Bug fix: HELAS calling convention for wwwwxx and jwwwxx (4W-Vertex) 2005-05-25 Revised Makefile structure Eliminated obsolete references to ISAJET/SUSY (superseded by SLHA) 2005-05-19 Support for color in O'Mega (using color flow decomposition) New model QCD Parameter file changes that correspond to replaced SM module in O'Mega Bug fixes in MSSM (O'Mega) parameter file 2005-05-18 New event file formats, useful for LHC applications: ATHENA and Les Houches Accord (external fragmentation) Naive (i.e., leading 1/N) color factor now implemented both for incoming and outgoing partons 2005-01-26 include missing HELAS files for bundle pgf90 compatibility issues [note: still internal error in pgf90] ################################################################## 2004-12-13 RELEASE: version 1.40 compatibility fix: preprocessor marks in helas code now commented out minor bug fix: format string in madgraph source 2004-12-03 support for arbitray beam energies and directions allow for pT kick in structure functions bug fix: rounding error could result in zero cross section (compiler-dependent) 2004-10-07 simulate decay processes list fraction (of total width/cross section) instead of efficiency in process summary new cut/analysis parameters AA, AAD, CTA: absolute polar angle 2004-10-04 Replaced Madgraph I by Madgraph II. Main improvement: model no longer hardcoded introduced parameter reset_seed_each_process (useful for debugging) bug fix: color initialization for some processes was undefined 2004-09-21 don't compile unix_args module if it is not required ################################################################## 2004-09-20 RELEASE: version 1.30 g95 compatibility issues resolved some (irrelevant) memory leaks closed removed obsolete warning in circe1 manual update (essentially) finished 2004-08-03 O'Mega RELEASE: version 0.9 O'Mega, src/trie.mli, src/trie.ml: make interface compatible with the O'Caml 3.08 library (remains compatible with older versions). Implementation of unused functions still incomplete. 2004-07-26 minor fixes and improvements in make process 2004-06-29 workarounds for new Intel compiler bugs ... no rebuild of madgraph/comphep executables after 'make clean' bug fix in phase space routine: wrong energy for massive initial particles bug fix in (new) model interface: name checks for antiparticles pre-run checks for comphep improved ww-strong model file extended Model files particle name fixes, chep SM vertices included 2004-06-22 O'Mega RELEASE: version 0.8 O'Mega MSSM: sign of W+/W-/A and W+/W-/Z couplings 2004-05-05 Fixed bug in PDFLIB interface: p+pbar was initialized as p+p (ThO) NAG compiler: set number of continuation lines to 200 as default Extended format for cross section summary; appears now in whizard.out Fixed 'bundle' feature 2004-04-28 Fixed compatibility with revised O'Mega SM_ac model Fixed problem with x=0 or x=1 when calling PDFLIB (ThO) Fixed bug in comphep module: Vtb was overlooked ################################################################## 2004-04-15 RELEASE: version 1.28 Fixed bug: Color factor was missing for O'Mega processes with four quarks and more Manual partially updated 2004-04-08 Support for grid files in binary format New default value show_histories=F (reduce output file size) Revised phase space switches: removed annihilation_lines, removed s_channel_resonance, changed meaning of extra_off_shell_lines, added show_deleted_channels Bug fixed which lead to omission of some phase space channels Color flow guessed only if requested by guess_color_flow 2004-03-10 New model interface: Only one model name specified in whizard.prc All model-dependent files reside in conf/models (modellib removed) 2004-03-03 Support for input/output in SUSY Les Houches Accord format Split event files if requested Support for overall time limit Support for CIRCE and CIRCE2 generator mode Support for reading beam events from file 2004-02-05 Fixed compiler problems with Intel Fortran 7.1 and 8.0 Support for catching signals ################################################################## 2003-08-06 RELEASE: version 1.27 User-defined PDF libraries as an alternative to the standard PDFLIB 2003-07-23 Revised phase space module: improved mappings for massless particles, equivalences of phase space channels are exploited Improved mapping for PDF (hadron colliders) Madgraph module: increased max number of color flows from 250 to 1000 ################################################################## 2003-06-23 RELEASE: version 1.26 CIRCE2 support Fixed problem with 'TC' integer kind [Intel compiler complained] 2003-05-28 Support for drawing histograms of grids Bug fixes for MSSM definitions ################################################################## 2003-05-22 RELEASE: version 1.25 Experimental MSSM support with ISAJET interface Improved capabilities of generating/analyzing weighted events Optional drawing phase space diagrams using FeynMF ################################################################## 2003-01-31 RELEASE: version 1.24 A few more fixes and workarounds (Intel and Lahey compiler) 2003-01-15 Fixes and workarounds needed for WHIZARD to run with Intel compiler Command-line option interface for the Lahey compiler Bug fix: problem with reading whizard.phs ################################################################## 2002-12-10 RELEASE: version 1.23 Command-line options (on some systems) Allow for initial particles in the event record, ordered: [beams, initials] - [remnants] - outgoing partons Support for PYTHIA 6.2: Les Houches external process interface String pythia_parameters can be up to 1000 characters long Select color flow states in (internal) analysis Bug fix in color flow content of raw event files Support for transversal polarization of fermion beams Cut codes: PHI now for absolute azimuthal angle, DPHI for distance 'Test' matrix elements optionally respect polarization User-defined code can be inserted for spectra, structure functions and fragmentation Time limits can be specified for adaptation and simulation User-defined file names and file directory Initial weights in input file no longer supported Bug fix in MadGraph (wave function counter could overflow) Bug fix: Gamelan (graphical analysis) was not built if noweb absent ################################################################## 2002-03-16 RELEASE: version 1.22 Allow for beam remnants in the event record 2002-03-01 Handling of aliases in whizard.prc fixed (aliases are whole tokens) 2002-02-28 Optimized phase space handling routines (total execution time reduced by 20-60%, depending on process) ################################################################## 2002-02-26 RELEASE: version 1.21 Fixed ISR formula (ISR was underestimated in previous versions). New version includes ISR in leading-log approximation up to third order. Parameter ISR_sqrts renamed to ISR_scale. ################################################################## 2002-02-19 RELEASE: version 1.20 New process-generating method 'test' (dummy matrix element) Compatibility with autoconf 2.50 and current O'Mega version 2002-02-05 Prevent integration channels from being dropped (optionally) New internal mapping for structure functions improves performance Old whizard.phx file deleted after recompiling (could cause trouble) 2002-01-24 Support for user-defined cuts and matrix element reweighting STDHEP output now written by write_events_format=20 (was 3) 2002-01-16 Improved structure function handling; small changes in user interface: new parameter structured_beams in &process_input parameter fixed_energy in &beam_input removed Support for multiple initial states Eta-phi (cone) cut possible (hadron collider applications) Fixed bug: Whizard library was not always recompiled when necessary Fixed bug: Default cuts were insufficient in some cases Fixed bug: Unusable phase space mappings generated in some cases 2001-12-06 Reorganized document source 2001-12-05 Preliminary CIRCE2 support (no functionality yet) 2001-11-27 Intel compiler support (does not yet work because of compiler bugs) New cut and analysis mode cos-theta* and related Fixed circular jetset_interface dependency warning Some broadcast routines removed (parallel support disabled anyway) Minor shifts in cleanup targets (Makefiles) Modified library search, check for pdflib8* 2001-08-06 Fixed bug: I/O unit number could be undefined when reading phase space Fixed bug: Unitialized variable could cause segfault when event generation was disabled Fixed bug: Undefined subroutine in CIRCE replacement module Enabled feature: TGCs in O'Mega (not yet CompHEP!) matrix elements (CompHEP model sm-GF #5, O'Mega model SM_ac) Fixed portability issue: Makefile did rely on PWD environment variable Fixed portability issue: PYTHIA library search ambiguity resolved 2001-08-01 Default whizard.prc and whizard.in depend on activated modules Fixed bug: TEX=latex was not properly enabled when making plots 2001-07-20 Fixed output settings in PERL script calls Cache enabled in various configure checks 2001-07-13 Support for multiple processes in a single WHIZARD run. The integrations are kept separate, but the generated events are mixed The whizard.evx format has changed (incompatible), including now the color flow information for PYTHIA fragmentation Output files are now process-specific, except for the event file Phase space file whizard.phs (if present) is used only as input, program-generated phase space is now in whizard.phx 2001-07-10 Bug fix: Undefined parameters in parameters_SM_ac.f90 removed 2001-07-04 Bug fix: Compiler options for the case OMEGA is disabled Small inconsistencies in whizard.out format fixed 2001-07-01 Workaround for missing PDFLIB dummy routines in PYTHIA library ################################################################## 2001-06-30 RELEASE: version 1.13 Default path /cern/pro/lib in configure script 2001-06-20 New fragmentation option: Interface for PYTHIA with full color flow information, beam remnants etc. 2001-06-18 Severe bug fixed in madgraph interface: 3-gluon coupling was missing Enabled color flow information in madgraph 2001-06-11 VAMP interface module rewritten Revised output format: Multiple VAMP iterations count as one WHIZARD iteration in integration passes 1 and 3 Improved message and error handling Bug fix in VAMP: handle exceptional cases in rebinning_weights 2001-05-31 new parameters for grid adaptation: accuracy_goal and efficiency_goal ################################################################## 2001-05-29 RELEASE: version 1.12 bug fixes (compilation problems): deleted/modified unused functions 2001-05-16 diagram selection improved and documented 2001-05-06 allow for disabling packages during configuration 2001-05-03 slight changes in whizard.out format; manual extended ################################################################## 2001-04-20 RELEASE: version 1.11 fixed some configuration and compilation problems (PDFLIB etc.) 2001-04-18 linked PDFLIB: support for quark/gluon structure functions 2001-04-05 parameter interface written by PERL script SM_ac model file: fixed error in continuation line 2001-03-13 O'Mega, O'Caml 3.01: incompatible changes O'Mega, src/trie.mli: add covariance annotation to T.t This breaks O'Caml 3.00, but is required for O'Caml 3.01. O'Mega, many instances: replace `sig include Module.T end' by `Module.T', since the bug is fixed in O'Caml 3.01 2001-02-28 O'Mega, src/model.mli: new field Model.vertices required for model functors, will retire Model.fuse2, Model.fuse3, Model.fusen soon. ################################################################## 2001-03-27 RELEASE: version 1.10 reorganized the modules as libraries linked PYTHIA: support for parton fragmentation 2000-12-14 fixed some configuration problems (if noweb etc. are absent) ################################################################## 2000-12-01 RELEASE of first public version: version 1.00beta Index: trunk/vamp/src/vamp.nw =================================================================== --- trunk/vamp/src/vamp.nw (revision 8827) +++ trunk/vamp/src/vamp.nw (revision 8828) @@ -1,4530 +1,4530 @@ -% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- +% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP main code as NOWEB source @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{The Abstract Datatype \texttt{vamp\_grid}} <<[[vamp.f90]]>>= ! vamp.f90 -- <> @ \begin{dubious} \index{Fortran problem} NAG f95 requires this split. Check with the Fortran community, if it is really necessary, or a bug! The problem is that this split forces us the expose the components of [[vamp_grid]]. \textbf{NB:} with the introduction of [[vamp_equivalences]], this question has (probably) become academic. \end{dubious} <<[[vamp.f90]]>>= module vamp_grid_type use kinds use divisions private <> end module vamp_grid_type @ %def vamp_grid_type @ \begin{dubious} By WK for WHIZARD. \end{dubious} <<[[vamp.f90]]>>= module vamp_equivalences use kinds use divisions use vamp_grid_type !NODEP! implicit none private <> <> <> contains <> end module vamp_equivalences @ %def vamp_equivalences @ <>= type, public :: vamp_equivalence_t integer :: left, right integer, dimension(:), allocatable :: permutation integer, dimension(:), allocatable :: mode end type vamp_equivalence_t @ <>= type, public :: vamp_equivalences_t type(vamp_equivalence_t), dimension(:), allocatable :: eq integer :: n_eq, n_ch integer, dimension(:), allocatable :: pointer logical, dimension(:), allocatable :: independent integer, dimension(:), allocatable :: equivalent_to_ch integer, dimension(:), allocatable :: multiplicity integer, dimension(:), allocatable :: symmetry logical, dimension(:,:), allocatable :: div_is_invariant end type vamp_equivalences_t @ <>= integer, parameter, public :: & VEQ_IDENTITY = 0, VEQ_INVERT = 1, VEQ_SYMMETRIC = 2, VEQ_INVARIANT = 3 @ <>= subroutine vamp_equivalence_init (eq, n_dim) type(vamp_equivalence_t), intent(inout) :: eq integer, intent(in) :: n_dim allocate (eq%permutation(n_dim), eq%mode(n_dim)) end subroutine vamp_equivalence_init @ %def vamp_equivalence_init @ <>= public :: vamp_equivalences_init @ <>= subroutine vamp_equivalences_init (eq, n_eq, n_ch, n_dim) type(vamp_equivalences_t), intent(inout) :: eq integer, intent(in) :: n_eq, n_ch, n_dim integer :: i eq%n_eq = n_eq eq%n_ch = n_ch allocate (eq%eq(n_eq)) allocate (eq%pointer(n_ch+1)) do i=1, n_eq call vamp_equivalence_init (eq%eq(i), n_dim) end do allocate (eq%independent(n_ch), eq%equivalent_to_ch(n_ch)) allocate (eq%multiplicity(n_ch), eq%symmetry(n_ch)) allocate (eq%div_is_invariant(n_ch, n_dim)) eq%independent = .true. eq%equivalent_to_ch = 0 eq%multiplicity = 0 eq%symmetry = 0 eq%div_is_invariant = .false. end subroutine vamp_equivalences_init @ %def vamp_equivalences_init @ <>= subroutine vamp_equivalence_final (eq) type(vamp_equivalence_t), intent(inout) :: eq deallocate (eq%permutation, eq%mode) end subroutine vamp_equivalence_final @ %def vamp_equivalence_final @ <>= public :: vamp_equivalences_final @ <>= subroutine vamp_equivalences_final (eq) type(vamp_equivalences_t), intent(inout) :: eq ! integer :: i ! do i=1, eq%n_eq ! call vamp_equivalence_final (eq%eq(i)) ! end do if (allocated (eq%eq)) deallocate (eq%eq) if (allocated (eq%pointer)) deallocate (eq%pointer) if (allocated (eq%multiplicity)) deallocate (eq%multiplicity) if (allocated (eq%symmetry)) deallocate (eq%symmetry) if (allocated (eq%independent)) deallocate (eq%independent) if (allocated (eq%equivalent_to_ch)) deallocate (eq%equivalent_to_ch) if (allocated (eq%div_is_invariant)) deallocate (eq%div_is_invariant) eq%n_eq = 0 eq%n_ch = 0 end subroutine vamp_equivalences_final @ %def vamp_equivalences_final @ <>= subroutine vamp_equivalence_write (eq, unit) integer, intent(in), optional :: unit integer :: u type(vamp_equivalence_t), intent(in) :: eq u = 6; if (present (unit)) u = unit write (u, "(3x,A,2(1x,I0))") "Equivalent channels:", eq%left, eq%right write (u, "(5x,A,99(1x,I0))") "Permutation:", eq%permutation write (u, "(5x,A,99(1x,I0))") "Mode: ", eq%mode end subroutine vamp_equivalence_write @ %def vamp_equivalence_write @ <>= public :: vamp_equivalences_write @ <>= subroutine vamp_equivalences_write (eq, unit) type(vamp_equivalences_t), intent(in) :: eq integer, intent(in), optional :: unit integer :: u integer :: ch, i u = 6; if (present (unit)) u = unit write (u, "(1x,A)") "Inequivalent channels:" if (allocated (eq%independent)) then do ch=1, eq%n_ch if (eq%independent(ch)) then write (u, "(3x,A,1x,I0,A,4x,A,I0,4x,A,I0,4x,A,999(L1))") & "Channel", ch, ":", & "Mult. = ", eq%multiplicity(ch), & "Symm. = ", eq%symmetry(ch), & "Invar.: ", eq%div_is_invariant(ch,:) end if end do else write (u, "(3x,A)") "[not allocated]" end if write (u, "(1x,A)") "Equivalence list:" if (allocated (eq%eq)) then do i=1, size (eq%eq) call vamp_equivalence_write (eq%eq(i), u) end do else write (u, "(3x,A)") "[not allocated]" end if end subroutine vamp_equivalences_write @ %def vamp_equivalences_write @ <>= -public :: vamp_equivalence_set +public :: vamp_equivalence_set @ <>= subroutine vamp_equivalence_set (eq, i, left, right, perm, mode) type(vamp_equivalences_t), intent(inout) :: eq integer, intent(in) :: i integer, intent(in) :: left, right integer, dimension(:), intent(in) :: perm, mode eq%eq(i)%left = left eq%eq(i)%right = right eq%eq(i)%permutation = perm eq%eq(i)%mode = mode end subroutine vamp_equivalence_set @ %def vamp_equivalence_set @ <>= public :: vamp_equivalences_complete @ <>= subroutine vamp_equivalences_complete (eq) type(vamp_equivalences_t), intent(inout) :: eq integer :: i, ch ch = 0 do i=1, eq%n_eq if (ch /= eq%eq(i)%left) then ch = eq%eq(i)%left eq%pointer(ch) = i end if end do eq%pointer(ch+1) = eq%n_eq + 1 do ch=1, eq%n_ch call set_multiplicities (eq%eq(eq%pointer(ch):eq%pointer(ch+1)-1)) end do ! call write (6, eq) contains subroutine set_multiplicities (eq_ch) type(vamp_equivalence_t), dimension(:), intent(in) :: eq_ch integer :: i if (.not. all(eq_ch%left == ch) .or. eq_ch(1)%right > ch) then do i = 1, size (eq_ch) call vamp_equivalence_write (eq_ch(i)) end do stop "VAMP: Equivalences: Something's wrong with equivalence ordering" end if eq%symmetry(ch) = count (eq_ch%right == ch) if (mod (size(eq_ch), eq%symmetry(ch)) /= 0) then do i = 1, size (eq_ch) call vamp_equivalence_write (eq_ch(i)) end do stop "VAMP: Equivalences: Something's wrong with permutation count" end if eq%multiplicity(ch) = size (eq_ch) / eq%symmetry(ch) eq%independent(ch) = all (eq_ch%right >= ch) eq%equivalent_to_ch(ch) = eq_ch(1)%right eq%div_is_invariant(ch,:) = eq_ch(1)%mode == VEQ_INVARIANT end subroutine set_multiplicities end subroutine vamp_equivalences_complete @ %def vamp_equivalences_complete @ <<[[vamp.f90]]>>= module vamp_rest use kinds use utils use exceptions use divisions use tao_random_numbers use vamp_stat use linalg use iso_fortran_env use vamp_grid_type !NODEP! use vamp_equivalences !NODEP! implicit none private <> <> <> <> <> contains <> end module vamp_rest @ %def vamp_rest -@ +@ <<[[vamp.f90]]>>= module vamp use vamp_grid_type !NODEP! use vamp_rest !NODEP! use vamp_equivalences !NODEP! public end module vamp @ %def vamp @ N.B.: In \texttt{Fortran95} we will be able to give default initializations to components of the type. In particular, we can use the [[null ()]] intrinsic to initialize the pointers to a disassociated state. Until then, the user \emph{must} call the initializer [[vamp_create_grid]] himself of herself, because we can't check for the allocation status of the pointers in \texttt{Fortran90} or~\texttt{F}. \index{deficiencies in \protect\texttt{Fortran90} and \protect\texttt{F}} \begin{dubious} Augment this datatype by [[real(kind=default), dimension(2) :: mu_plus, mu_minus]] to record positive and negative weight separately, so that we can estimmate the efficiency for reweighting from indefinite weights to $\{+1,-1\}$. [WK 2015/11/06: done. Those values are recorded but not used inside \texttt{vamp}. They can be retrieved by the caller.] \end{dubious} \begin{dubious} WK 2015/11/06: [[f_min]] and [[f_max]] work with the absolute value of the matrix element, so they record the minimum and maximum absolute value. \end{dubious} <>= type, public :: vamp_grid ! private !: forced by \texttt{use} association in interface type(division_t), dimension(:), pointer :: div => null () real(kind=default), dimension(:,:), pointer :: map => null () real(kind=default), dimension(:), pointer :: mu_x => null () real(kind=default), dimension(:), pointer :: sum_mu_x => null () real(kind=default), dimension(:,:), pointer :: mu_xx => null () real(kind=default), dimension(:,:), pointer :: sum_mu_xx => null () real(kind=default), dimension(2) :: mu real(kind=default), dimension(2) :: mu_plus, mu_minus real(kind=default) :: sum_integral, sum_weights, sum_chi2 real(kind=default) :: calls, dv2g, jacobi real(kind=default) :: f_min, f_max real(kind=default) :: mu_gi, sum_mu_gi integer, dimension(:), pointer :: num_div => null () integer :: num_calls, calls_per_cell logical :: stratified = .true. logical :: all_stratified = .true. logical :: quadrupole = .false. logical :: independent integer :: equivalent_to_ch, multiplicity end type vamp_grid @ %def vamp_grid -@ +@ <>= public :: vamp_copy_grid, vamp_delete_grid @ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Container for application data} \begin{dubious} By WK for WHIZARD. We define an empty data type that the application can extend according to its needs. The purpose is to hold all sorts of data that are predefined and accessed during the call of the sampling function. - + The actual interface for the sampling function is PURE. Nevertheless, we can implement side effects via pointer components of a [[vamp_data_t]] extension. \end{dubious} <>= type, public :: vamp_data_t end type vamp_data_t @ %def vamp_data_t @ This is the object to be passed if we want nothing else: <>= type(vamp_data_t), parameter, public :: NO_DATA = vamp_data_t () @ %def NO_DATA @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Initialization} <>= public :: vamp_create_grid, vamp_create_empty_grid @ %def vamp_create_grid vamp_create_empty_grid @ Create a fresh grid for the integration domain \begin{equation} \mathcal{D} = [D_{1,1},D_{2,1}] \times [D_{1,2},D_{2,2}] \times \ldots \times [D_{1,n},D_{2,n}] \end{equation} dropping all accumulated results. This function \emph{must not} be called twice on the first argument, without an intervening [[vamp_delete_grid]]. Iff the second variable is given, it will be the number of sampling points for the call to [[vamp_sample_grid]]. <>= pure subroutine vamp_create_grid & (g, domain, num_calls, num_div, & stratified, quadrupole, covariance, map, exc) type(vamp_grid), intent(inout) :: g real(kind=default), dimension(:,:), intent(in) :: domain integer, intent(in) :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole, covariance real(kind=default), dimension(:,:), intent(in), optional :: map type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "vamp_create_grid" real(kind=default), dimension(size(domain,dim=2)) :: & x_min, x_max, x_min_true, x_max_true integer :: ndim ndim = size (domain, dim=2) allocate (g%div(ndim), g%num_div(ndim)) x_min = domain(1,:) x_max = domain(2,:) if (present (map)) then allocate (g%map(ndim,ndim)) g%map = map x_min_true = x_min x_max_true = x_max call map_domain (g%map, x_min_true, x_max_true, x_min, x_max) call create_division (g%div, x_min, x_max, x_min_true, x_max_true) else nullify (g%map) call create_division (g%div, x_min, x_max) end if g%num_calls = num_calls if (present (num_div)) then g%num_div = num_div else g%num_div = NUM_DIV_DEFAULT end if g%stratified = .true. g%quadrupole = .false. g%independent = .true. g%equivalent_to_ch = 0 g%multiplicity = 1 nullify (g%mu_x, g%mu_xx, g%sum_mu_x, g%sum_mu_xx) call vamp_discard_integral & (g, num_calls, num_div, stratified, quadrupole, covariance, exc) end subroutine vamp_create_grid @ %def vamp_create_grid @ %def ndim domain dx grid @ Below, we assume that $[[NUM_DIV_DEFAULT]] \ge 6$, but we will never go that low anyway. <>= integer, private, parameter :: NUM_DIV_DEFAULT = 20 @ %def NUM_DIV_DEFAULT @ Given a linear map~$M$, find a domain~$\mathcal{D}_0$ such that \begin{equation} \mathcal{D} \subset M \mathcal{D}_0 \end{equation} <>= private :: map_domain @ If we can assume that~$M$ is orthogonal~$M^{-1}=M^T$, then we just have to rotate~$\mathcal{D}$ and determine the maximal and minimal extension of the corners: \begin{equation} \mathcal{D}_0^T = \overline{\mathcal{D}^T M} \end{equation} The corners are just the powerset of the maximal and minimal extension in each coordinate. It is determined most easily with binary counting: <>= pure subroutine map_domain (map, true_xmin, true_xmax, xmin, xmax) real(kind=default), dimension(:,:), intent(in) :: map real(kind=default), dimension(:), intent(in) :: true_xmin, true_xmax real(kind=default), dimension(:), intent(out) :: xmin, xmax real(kind=default), dimension(2**size(xmin),size(xmin)) :: corners integer, dimension(size(xmin)) :: zero_to_n integer :: j, ndim, perm ndim = size (xmin) zero_to_n = (/ (j, j=0,ndim-1) /) do perm = 1, 2**ndim corners (perm,:) = & merge (true_xmin, true_xmax, btest (perm-1, zero_to_n)) end do corners = matmul (corners, map) xmin = minval (corners, dim=1) xmax = maxval (corners, dim=1) end subroutine map_domain @ %def map_domain -@ +@ <>= elemental subroutine vamp_create_empty_grid (g) type(vamp_grid), intent(inout) :: g nullify (g%div, g%num_div, g%map, g%mu_x, g%mu_xx, g%sum_mu_x, g%sum_mu_xx) end subroutine vamp_create_empty_grid @ %def vamp_create_empty_grid -@ +@ <>= public :: vamp_discard_integral @ Keep the current optimized grid, but drop the accumulated results for the integral (value and errors). Iff the second variable is given, it will be the new number of sampling points for the next call to [[vamp_sample_grid]]. <>= pure subroutine vamp_discard_integral & (g, num_calls, num_div, stratified, quadrupole, covariance, exc, & & independent, equivalent_to_ch, multiplicity) type(vamp_grid), intent(inout) :: g integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole, covariance type(exception), intent(inout), optional :: exc logical, intent(in), optional :: independent integer, intent(in), optional :: equivalent_to_ch, multiplicity character(len=*), parameter :: FN = "vamp_discard_integral" g%mu = 0.0 g%mu_plus = 0.0 g%mu_minus = 0.0 g%mu_gi = 0.0 g%sum_integral = 0.0 g%sum_weights = 0.0 g%sum_chi2 = 0.0 g%sum_mu_gi = 0.0 if (associated (g%sum_mu_x)) then g%sum_mu_x = 0.0 g%sum_mu_xx = 0.0 end if call set_grid_options (g, num_calls, num_div, stratified, quadrupole, & independent, equivalent_to_ch, multiplicity) if ((present (num_calls)) & .or. (present (num_div)) & .or. (present (stratified)) & .or. (present (quadrupole)) & .or. (present (covariance))) then call vamp_reshape_grid & (g, g%num_calls, g%num_div, & g%stratified, g%quadrupole, covariance, exc) end if end subroutine vamp_discard_integral @ %def vamp_discard_integral @ %def sum_integral sum_weights sum_chi2 -@ +@ <>= private :: set_grid_options @ <>= pure subroutine set_grid_options & (g, num_calls, num_div, stratified, quadrupole, & independent, equivalent_to_ch, multiplicity) type(vamp_grid), intent(inout) :: g integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole logical, intent(in), optional :: independent integer, intent(in), optional :: equivalent_to_ch, multiplicity if (present (num_calls)) then g%num_calls = num_calls end if if (present (num_div)) then g%num_div = num_div end if if (present (stratified)) then g%stratified = stratified end if if (present (quadrupole)) then g%quadrupole = quadrupole end if if (present (independent)) then g%independent = independent end if if (present (equivalent_to_ch)) then g%equivalent_to_ch = equivalent_to_ch end if if (present (multiplicity)) then g%multiplicity = multiplicity end if end subroutine set_grid_options @ %def set_grid_options @ %def num_calls num_div stratified quadrupole @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Setting Up the Initial Grid} Keep the current optimized grid and the accumulated results for the integral (value and errors). The second variable will be the new number of sampling points for the next call to [[vamp_sample_grid]]. <>= pure subroutine vamp_reshape_grid_internal & (g, num_calls, num_div, & stratified, quadrupole, covariance, exc, use_variance, & independent, equivalent_to_ch, multiplicity) type(vamp_grid), intent(inout) :: g integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole, covariance type(exception), intent(inout), optional :: exc logical, intent(in), optional :: use_variance logical, intent(in), optional :: independent integer, intent(in), optional :: equivalent_to_ch, multiplicity integer :: ndim, num_cells integer, dimension(size(g%div)) :: ng character(len=*), parameter :: FN = "vamp_reshape_grid_internal" ndim = size (g%div) call set_grid_options & (g, num_calls, num_div, stratified, quadrupole, & & independent, equivalent_to_ch, multiplicity) <> g%all_stratified = all (stratified_division (g%div)) if (present (covariance)) then ndim = size (g%div) if (covariance .and. (.not. associated (g%mu_x))) then allocate (g%mu_x(ndim), g%mu_xx(ndim,ndim)) allocate (g%sum_mu_x(ndim), g%sum_mu_xx(ndim,ndim)) g%sum_mu_x = 0.0 g%sum_mu_xx = 0.0 else if ((.not. covariance) .and. (associated (g%mu_x))) then deallocate (g%mu_x, g%mu_xx, g%sum_mu_x, g%sum_mu_xx) end if end if end subroutine vamp_reshape_grid_internal @ %def vamp_reshape_grid_internal @ %def stratified @ The [[use_variance]] argument is too dangerous for careless users, because the [[variance]] in the divisions will contain garbage before sampling and after reshaping. Build a fence with another routine. @ <>= private :: vamp_reshape_grid_internal public :: vamp_reshape_grid -@ +@ <>= pure subroutine vamp_reshape_grid & (g, num_calls, num_div, stratified, quadrupole, covariance, exc, & independent, equivalent_to_ch, multiplicity) type(vamp_grid), intent(inout) :: g integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole, covariance type(exception), intent(inout), optional :: exc logical, intent(in), optional :: independent integer, intent(in), optional :: equivalent_to_ch, multiplicity call vamp_reshape_grid_internal & (g, num_calls, num_div, stratified, quadrupole, covariance, & exc, use_variance = .false., & independent=independent, equivalent_to_ch=equivalent_to_ch, & multiplicity=multiplicity) end subroutine vamp_reshape_grid @ %def vamp_reshape_grid @ \texttt{vegas} operates in three different modes, which are chosen according to explicit user requests and to the relation of the requested number of sampling points to the dimensionality of the integration domain.\par The simplest case is when the user has overwritten the default of stratified sampling with the optional argument [[stratified]] in the call to [[vamp_create_grid]]. Then sample points will be choosen randomly with equal probability in each cell of the adaptive grid, as displayed in figure~\ref{fig:nonstrat}.\par The implementation is actually shared with the stratified case described below, by pretending that there is just a single stratification cell. The number of divisions for the adaptive grid is set to a compile time maximum value.\par If the user has agreed on stratified sampling then there are two cases, depending on the dimensionality of the integration region and the number of sample points. First we determine the number of divisions~$n_g$ (i.\,e.~[[ng]]) of the rigid grid such that there will be two sampling points per cell. \begin{equation} N_{\text{calls}} = 2\cdot (n_g)^{n_{\text{dim}}} \end{equation} The additional optional argument~$\hat n_g$ specifies an anisotropy in -the shape +the shape \begin{equation} n_{g,j} = \frac{\hat n_{g,j}}{\left(\prod_j\hat n_{g,j}\right)^{1/n_{\text{dim}}}} \left(\frac{N}{2}\right)^{1/n_{\text{dim}}} \end{equation} NB: \begin{equation} \prod_j n_{g,j} = \frac{N}{2} \end{equation} <>= if (g%stratified) then ng = (g%num_calls / 2.0 + 0.25)**(1.0/ndim) ! ng = ng * real (g%num_div, kind=default) & ! / (product (real (g%num_div, kind=default)))**(1.0/ndim) else ng = 1 end if call reshape_division (g%div, g%num_div, ng, use_variance) call clear_integral_and_variance (g%div) num_cells = product (rigid_division (g%div)) g%calls_per_cell = max (g%num_calls / num_cells, 2) g%calls = real (g%calls_per_cell) * real (num_cells) @ %def ng num_cells calls calls_per_cell @ \begin{equation} [[jacobi]] = J = \frac{\text{Volume}}{N_{\text{calls}}} \end{equation} and \begin{equation} [[dv2g]] = \frac{N_{\text{calls}}^2 \left((\Delta x)^{n_{\text{dim}}}\right)^2} {N_{\text{calls/cell}}^2(N_{\text{calls/cell}}-1)} = \frac{\left(\frac{N_{\text{calls}}}{N_{\text{cells}}}\right)^2} {N_{\text{calls/cell}}^2(N_{\text{calls/cell}}-1)} \end{equation} <>= -g%jacobi = product (volume_division (g%div)) / g%calls +g%jacobi = product (volume_division (g%div)) / g%calls g%dv2g = (g%calls / num_cells)**2 & / g%calls_per_cell / g%calls_per_cell / (g%calls_per_cell - 1.0) @ %def jacobi dv2g -@ +@ <>= call vamp_nullify_f_limits (g) @ When the grid is refined or reshaped, the recorded minimum and maximum of the sampling function should be nullified: -@ +@ <>= public :: vamp_nullify_f_limits @ <>= elemental subroutine vamp_nullify_f_limits (g) type(vamp_grid), intent(inout) :: g g%f_min = 1.0 g%f_max = 0.0 end subroutine vamp_nullify_f_limits @ %def vamp_nullify_f_limits @ %def f_min f_max -@ +@ <>= public :: vamp_rigid_divisions public :: vamp_get_covariance, vamp_nullify_covariance public :: vamp_get_variance, vamp_nullify_variance -@ +@ <>= pure function vamp_rigid_divisions (g) result (ng) type(vamp_grid), intent(in) :: g integer, dimension(size(g%div)) :: ng ng = rigid_division (g%div) end function vamp_rigid_divisions @ %def vamp_rigid_divisions -@ +@ <>= pure function vamp_get_covariance (g) result (cov) type(vamp_grid), intent(in) :: g real(kind=default), dimension(size(g%div),size(g%div)) :: cov if (associated (g%mu_x)) then if (abs (g%sum_weights) <= tiny (cov(1,1))) then where (g%sum_mu_xx == 0.0_default) cov = 0.0 elsewhere cov = huge (cov(1,1)) endwhere else cov = g%sum_mu_xx / g%sum_weights & - outer_product (g%sum_mu_x, g%sum_mu_x) / g%sum_weights**2 end if else cov = 0.0 end if end function vamp_get_covariance @ %def vamp_get_covariance -@ +@ <>= elemental subroutine vamp_nullify_covariance (g) type(vamp_grid), intent(inout) :: g if (associated (g%mu_x)) then g%sum_mu_x = 0 g%sum_mu_xx = 0 end if end subroutine vamp_nullify_covariance @ %def vamp_nullify_covariance -@ +@ <>= elemental function vamp_get_variance (g) result (v) type(vamp_grid), intent(in) :: g real(kind=default) :: v if (abs (g%sum_weights) <= tiny (v)) then if (g%sum_mu_gi == 0.0_default) then v = 0.0 else v = huge (v) end if else v = g%sum_mu_gi / g%sum_weights end if end function vamp_get_variance @ %def vamp_get_variance -@ +@ <>= elemental subroutine vamp_nullify_variance (g) type(vamp_grid), intent(inout) :: g g%sum_mu_gi = 0 end subroutine vamp_nullify_variance @ %def vamp_nullify_variance @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Sampling} <>= public :: vamp_sample_grid public :: vamp_sample_grid0 public :: vamp_refine_grid public :: vamp_refine_grids -@ +@ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Simple Non-Adaptive Sampling: $S_0$} <>= subroutine vamp_sample_grid0 & (rng, g, func, data, channel, weights, grids, exc, & negative_weights) type(tao_random_state), intent(inout) :: rng type(vamp_grid), intent(inout) :: g class(vamp_data_t), intent(in) :: data integer, intent(in), optional :: channel real(kind=default), dimension(:), intent(in), optional :: weights type(vamp_grid), dimension(:), intent(in), optional :: grids type(exception), intent(inout), optional :: exc <> character(len=*), parameter :: FN = "vamp_sample_grid0" logical, intent(in), optional :: negative_weights <> integer :: ndim logical :: neg_w ndim = size (g%div) neg_w = .false. if (present (negative_weights)) neg_w = negative_weights <> <> loop_over_cells: do <> <> <> end do loop_over_cells <> end subroutine vamp_sample_grid0 @ %def vamp_sample_grid0 @ Count cells like a $n_g$-ary number---i.e.~$(1,\ldots,1,1)$, $(1,\ldots,1,2)$, $\ldots$, $(1,\ldots,1,n_g)$, $(1,\ldots,2,1)$, $\ldots$, $(n_g,\ldots,n_g,n_g-1)$, $(n_g,\ldots,n_g,n_g)$---and terminate when [[all (cell == 1)]] again. <>= do j = ndim, 1, -1 cell(j) = modulo (cell(j), rigid_division (g%div(j))) + 1 if (cell(j) /= 1) then cycle loop_over_cells end if end do exit loop_over_cells @ %def cell @ <>= g%mu = 0.0 g%mu_plus = 0.0 g%mu_minus = 0.0 cell = 1 call clear_integral_and_variance (g%div) if (associated (g%mu_x)) then g%mu_x = 0.0 g%mu_xx = 0.0 end if if (present (channel)) then g%mu_gi = 0.0 end if -@ +@ <>= real(kind=default), parameter :: & eps = tiny (1._default) / epsilon (1._default) character(len=6) :: buffer -@ +@ <>= integer :: j, k integer, dimension(size(g%div)) :: cell @ %def j k cell @ <>= sum_f = 0.0 sum_f_plus = 0.0 sum_f_minus = 0.0 sum_f2 = 0.0 sum_f2_plus = 0.0 sum_f2_minus = 0.0 do k = 1, g%calls_per_cell <> <<[[f = wgt * func (x, weights, channel)]], iff [[x]] inside [[true_domain]]>> <> end do @ %def sum_f sum_f2 sum_f_plus sum_f_minus @ We are using the generic procedure [[tao_random_number]] from the [[tao_random_numbers]] module for generating an array of uniform deviates. \index{dependences on external modules} \index{deficiencies in \protect\texttt{Fortran90} and \protect\texttt{F}} A better alternative would be to pass the random number generator as an argument to [[vamp_sample_grid]]. Unfortunately, it is not possible to pass \emph{generic} procedures in \texttt{Fortran90}, \texttt{Fortran95}, or \texttt{F}. While we could export a specific procedure from [[tao_random_numbers]], a more serious problem is that we have to pass the state [[rng]] of the random number generator as a [[tao_random_state]] anyway and we have to hardcode the random number generator anyway. <>= call tao_random_number (rng, r) call inject_division (g%div, real (r, kind=default), & cell, x, x_mid, ia, wgts) wgt = g%jacobi * product (wgts) if (associated (g%map)) then x = matmul (g%map, x) end if @ %def r ia wgt wgts x x_mid @ This somewhat contorted nested [[if]] constructs allow to minimize the number of calls to [[func]]. This is useful, since [[func]] is the most expensive part of real world applications. Also [[func]] might be singular outside of [[true_domain]].\par The original \texttt{vegas} used to call [[f = wgt * func (x, wgt)]] below to allow [[func]] to use [[wgt]] (i.e.~$1/p(x)$) for integrating another function at the same time. This form of ``parallelism'' relies on side effects and is therefore impossible with pure functions. Consequently, it is not supported in the current implementation. <<[[f = wgt * func (x, weights, channel)]], iff [[x]] inside [[true_domain]]>>= if (associated (g%map)) then if (all (inside_division (g%div, x))) then f = wgt * func (x, data, weights, channel, grids) else f = 0.0 end if else f = wgt * func (x, data, weights, channel, grids) end if @ %def f -@ +@ <>= if (g%f_min > g%f_max) then g%f_min = abs (f) * g%calls g%f_max = abs (f) * g%calls else if (abs (f) * g%calls < g%f_min) then g%f_min = abs (f) * g%calls else if (abs (f) * g%calls > g%f_max) then g%f_max = abs (f) * g%calls end if -@ +@ <>= f2 = f * f sum_f = sum_f + f sum_f2 = sum_f2 + f2 if (f > 0) then sum_f_plus = sum_f_plus + f sum_f2_plus = sum_f2_plus + f * f else if (f < 0) then sum_f_minus = sum_f_minus + f sum_f2_minus = sum_f2_minus + f * f end if call record_integral (g%div, ia, f) ! call record_efficiency (g%div, ia, f/g%f_max) if ((associated (g%mu_x)) .and. (.not. g%all_stratified)) then g%mu_x = g%mu_x + x * f g%mu_xx = g%mu_xx + outer_product (x, x) * f end if if (present (channel)) then g%mu_gi = g%mu_gi + f2 end if @ %def f2 sum_f sum_f2 sum_f_plus sum_f_minus sum_f2_plus sum_f2_minus -@ +@ <>= real(kind=default) :: wgt, f, f2 real(kind=default) :: sum_f, sum_f2, var_f real(kind=default) :: sum_f_plus, sum_f2_plus, var_f_plus real(kind=default) :: sum_f_minus, sum_f2_minus, var_f_minus real(kind=default), dimension(size(g%div)):: x, x_mid, wgts real(kind=default), dimension(size(g%div)):: r integer, dimension(size(g%div)) :: ia -@ %def wgt f f2 +@ %def wgt f f2 @ %def sum_f sum_f2 var_f @ %def sum_f_plus sum_f2_plus var_f_plus @ %def sum_f_minus sum_f2_minus var_f_minus @ %def r x x_mid wgts wgt ia @ \begin{equation} \sigma^2 \cdot N^2_{\text{calls/cell}}(N_{\text{calls/cell}}-1) = \mathop{\textrm{var}}(f) = N^2\sigma^2 \left( \left\langle \frac{f^2}{p} \right\rangle - \langle f \rangle^2 \right) \end{equation} \label{pg:var_f} <>= var_f = sum_f2 * g%calls_per_cell - sum_f**2 var_f_plus = sum_f2_plus * g%calls_per_cell - sum_f_plus**2 var_f_minus = sum_f2_minus * g%calls_per_cell - sum_f_minus**2 -if (var_f <= 0.0) then +if (var_f <= 0.0) then var_f = tiny (1.0_default) end if -if (sum_f_plus /= 0 .and. var_f_plus <= 0) then +if (sum_f_plus /= 0 .and. var_f_plus <= 0) then var_f_plus = tiny (1.0_default) end if -if (sum_f_minus /= 0 .and. var_f_minus <= 0) then +if (sum_f_minus /= 0 .and. var_f_minus <= 0) then var_f_minus = tiny (1.0_default) end if g%mu = g%mu + (/ sum_f, var_f /) g%mu_plus = g%mu_plus + (/ sum_f_plus, var_f_plus /) g%mu_minus = g%mu_minus + (/ sum_f_minus, var_f_minus /) call record_variance (g%div, ia, var_f) if ((associated (g%mu_x)) .and. g%all_stratified) then if (associated (g%map)) then x_mid = matmul (g%map, x_mid) end if g%mu_x = g%mu_x + x_mid * var_f g%mu_xx = g%mu_xx + outer_product (x_mid, x_mid) * var_f end if @ %def sum_x sum_xx var_f @ \begin{equation} \sigma^2 = \frac{\left(\frac{N_{\text{calls}}}{N_{\text{cells}}}\right)^2}% {N^2_{\text{calls/cell}}(N_{\text{calls/cell}}-1)} \sum_{\text{cells}} \sigma^2_{\text{cell}} \cdot N^2_{\text{calls/cell}}(N_{\text{calls/cell}}-1) \end{equation} where the~$N_{\text{calls}}^2$ cancels the corresponding factor in the Jacobian and the~$N_{\text{cells}}^{-2}$ is the result of stratification. In order to avoid numerical noise for some OS when using 80bit precision, we wrap the numerical resetting into a negative weights-only if-clause. <>= g%mu(2) = g%mu(2) * g%dv2g if (g%mu(2) < eps * max (g%mu(1)**2, 1._default)) then g%mu(2) = eps * max (g%mu(1)**2, 1._default) end if if (neg_w) then g%mu_plus(2) = g%mu_plus(2) * g%dv2g if (g%mu_plus(2) < eps * max (g%mu_plus(1)**2, 1._default)) then g%mu_plus(2) = eps * max (g%mu_plus(1)**2, 1._default) end if g%mu_minus(2) = g%mu_minus(2) * g%dv2g if (g%mu_minus(2) < eps * max (g%mu_minus(1)**2, 1._default)) then g%mu_minus(2) = eps * max (g%mu_minus(1)**2, 1._default) end if end if -@ +@ <>= if (g%mu(1)>0) then g%sum_integral = g%sum_integral + g%mu(1) / g%mu(2) g%sum_weights = g%sum_weights + 1.0 / g%mu(2) g%sum_chi2 = g%sum_chi2 + g%mu(1)**2 / g%mu(2) if (associated (g%mu_x)) then if (g%all_stratified) then g%mu_x = g%mu_x / g%mu(2) g%mu_xx = g%mu_xx / g%mu(2) else g%mu_x = g%mu_x / g%mu(1) g%mu_xx = g%mu_xx / g%mu(1) end if g%sum_mu_x = g%sum_mu_x + g%mu_x / g%mu(2) g%sum_mu_xx = g%sum_mu_xx + g%mu_xx / g%mu(2) end if if (present (channel)) then g%sum_mu_gi = g%sum_mu_gi + g%mu_gi / g%mu(2) end if else if (neg_w) then g%sum_integral = g%sum_integral + g%mu(1) / g%mu(2) g%sum_weights = g%sum_weights + 1.0 / g%mu(2) g%sum_chi2 = g%sum_chi2 + g%mu(1)**2 / g%mu(2) if (associated (g%mu_x)) then if (g%all_stratified) then g%mu_x = g%mu_x / g%mu(2) g%mu_xx = g%mu_xx / g%mu(2) else g%mu_x = g%mu_x / g%mu(1) g%mu_xx = g%mu_xx / g%mu(1) end if g%sum_mu_x = g%sum_mu_x + g%mu_x / g%mu(2) g%sum_mu_xx = g%sum_mu_xx + g%mu_xx / g%mu(2) end if if (present (channel)) then g%sum_mu_gi = g%sum_mu_gi + g%mu_gi / g%mu(2) end if else if (present(channel) .and. g%mu(1)==0) then write (buffer, "(I6)") channel call raise_exception (exc, EXC_WARN, "! vamp", & "Function identically zero in channel " // buffer) else if (present(channel) .and. g%mu(1)<0) then write (buffer, "(I6)") channel call raise_exception (exc, EXC_ERROR, "! vamp", & "Negative integral in channel " // buffer) end if g%sum_integral = 0 g%sum_chi2 = 0 g%sum_weights = 0 end if @ %def sum_integral sum_chi2 sum_weights -@ +@ <>= if (present (channel) .neqv. present (weights)) then call raise_exception (exc, EXC_FATAL, FN, & "channel and weights required together") return end if -@ +@ <>= public :: vamp_probability -@ +@ <>= pure function vamp_probability (g, x) result (p) type(vamp_grid), intent(in) :: g real(kind=default), dimension(:), intent(in) :: x real(kind=default) :: p p = product (probability (g%div, x)) end function vamp_probability @ %def vamp_probability -@ +@ \begin{dubious} [[%variance]] should be private to [[division]] \end{dubious} <>= subroutine vamp_apply_equivalences (g, eq) type(vamp_grids), intent(inout) :: g type(vamp_equivalences_t), intent(in) :: eq integer :: n_ch, n_dim, nb, i, ch, ch_src, dim, dim_src integer, dimension(:,:), allocatable :: n_bin real(kind=default), dimension(:,:,:), allocatable :: var_tmp n_ch = size (g%grids) if (n_ch == 0) return n_dim = size (g%grids(1)%div) allocate (n_bin(n_ch, n_dim)) do ch = 1, n_ch do dim = 1, n_dim n_bin(ch, dim) = size (g%grids(ch)%div(dim)%variance) end do end do allocate (var_tmp (maxval(n_bin), n_dim, n_ch)) var_tmp = 0 do i=1, eq%n_eq ch = eq%eq(i)%left ch_src = eq%eq(i)%right do dim=1, n_dim nb = n_bin(ch_src, dim) dim_src = eq%eq(i)%permutation(dim) select case (eq%eq(i)%mode(dim)) case (VEQ_IDENTITY) var_tmp(:nb,dim,ch) = var_tmp(:nb,dim,ch) & & + g%grids(ch_src)%div(dim_src)%variance case (VEQ_INVERT) var_tmp(:nb,dim,ch) = var_tmp(:nb,dim,ch) & & + g%grids(ch_src)%div(dim_src)%variance(nb:1:-1) case (VEQ_SYMMETRIC) var_tmp(:nb,dim,ch) = var_tmp(:nb,dim,ch) & & + g%grids(ch_src)%div(dim_src)%variance / 2 & & + g%grids(ch_src)%div(dim_src)%variance(nb:1:-1)/2 case (VEQ_INVARIANT) var_tmp(:nb,dim,ch) = 1 end select end do end do do ch=1, n_ch do dim=1, n_dim g%grids(ch)%div(dim)%variance = var_tmp(:n_bin(ch, dim),dim,ch) end do end do deallocate (var_tmp) deallocate (n_bin) end subroutine vamp_apply_equivalences @ %def vamp_apply_equivalences @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Grid Refinement: $r$} \begin{equation} n_{\text{div},j} \to \frac{Q_j n_{\text{div},j}}{\left(\prod_j Q_j\right)^{1/n_{\text{dim}}}} \end{equation} where \begin{equation} Q_j = \left(\sqrt{\mathop{\textrm{Var}}(\{m\}_j)}\right)^\alpha \end{equation} <>= pure subroutine vamp_refine_grid (g, exc) type(vamp_grid), intent(inout) :: g type(exception), intent(inout), optional :: exc real(kind=default), dimension(size(g%div)) :: quad integer :: ndim if (g%quadrupole) then ndim = size (g%div) quad = (quadrupole_division (g%div))**QUAD_POWER call vamp_reshape_grid_internal & (g, use_variance = .true., exc = exc, & num_div = int (quad / product (quad)**(1.0/ndim) * g%num_div)) else call refine_division (g%div) call vamp_nullify_f_limits (g) end if end subroutine vamp_refine_grid @ %def vamp_refine_grid -@ +@ <>= subroutine vamp_refine_grids (g) type(vamp_grids), intent(inout) :: g integer :: ch do ch=1, size(g%grids) call refine_division (g%grids(ch)%div) call vamp_nullify_f_limits (g%grids(ch)) end do end subroutine vamp_refine_grids @ %def vamp_refine_grids -@ +@ <>= real(kind=default), private, parameter :: QUAD_POWER = 0.5_default @ %def QUAD_POWER @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Adaptive Sampling: $S_n = S_0(rS_0)^n$} <>= subroutine vamp_sample_grid & (rng, g, func, data, iterations, & integral, std_dev, avg_chi2, accuracy, & channel, weights, grids, exc, history) type(tao_random_state), intent(inout) :: rng type(vamp_grid), intent(inout) :: g class(vamp_data_t), intent(in) :: data integer, intent(in) :: iterations real(kind=default), intent(out), optional :: integral, std_dev, avg_chi2 real(kind=default), intent(in), optional :: accuracy integer, intent(in), optional :: channel real(kind=default), dimension(:), intent(in), optional :: weights type(vamp_grid), dimension(:), intent(in), optional :: grids type(exception), intent(inout), optional :: exc type(vamp_history), dimension(:), intent(inout), optional :: history <> character(len=*), parameter :: FN = "vamp_sample_grid" real(kind=default) :: local_integral, local_std_dev, local_avg_chi2 integer :: iteration, ndim ndim = size (g%div) iterate: do iteration = 1, iterations call vamp_sample_grid0 & (rng, g, func, data, channel, weights, grids, exc) call vamp_average_iterations & (g, iteration, local_integral, local_std_dev, local_avg_chi2) <> <> if (iteration < iterations) call vamp_refine_grid (g) end do iterate <> end subroutine vamp_sample_grid @ %def local_integral local_std_dev local_avg_chi2 @ %def vamp_sample_grid @ %def func iterations integral std_dev avg_chi2 accuracy @ %def iteration @ Assuming that the iterations have been statistically independent, we can combine them with the usual formulae. \begin{subequations} \begin{align} \bar I &= \sigma_I^2 \sum_i \frac{I_i}{\sigma_i^2} \\ \frac{1}{\sigma_I^2} &= \sum_i \frac{1}{\sigma_i^2} \\ \chi^2 &= \sum_i \frac{(I_i-\bar I)^2}{\sigma_i^2} = \sum_i \frac{I_i^2}{\sigma_i^2} - \bar I \sum_i \frac{I_i}{\sigma_i^2} \end{align} \end{subequations} <>= elemental subroutine vamp_average_iterations_grid & (g, iteration, integral, std_dev, avg_chi2) type(vamp_grid), intent(in) :: g integer, intent(in) :: iteration real(kind=default), intent(out) :: integral, std_dev, avg_chi2 real(kind=default), parameter :: eps = 1000 * epsilon (1._default) if (g%sum_weights>0) then integral = g%sum_integral / g%sum_weights std_dev = sqrt (1.0 / g%sum_weights) avg_chi2 = & max ((g%sum_chi2 - g%sum_integral * integral) / (iteration-0.99), & 0.0_default) if (avg_chi2 < eps * g%sum_chi2) avg_chi2 = 0 else integral = 0 std_dev = 0 avg_chi2 = 0 end if end subroutine vamp_average_iterations_grid @ %def vamp_average_iterations_grid -@ +@ <>= public :: vamp_average_iterations private :: vamp_average_iterations_grid @ %def vamp_average_iterations -@ +@ <>= interface vamp_average_iterations module procedure vamp_average_iterations_grid end interface @ %def vamp_average_iterations @ Lepage suggests~\cite{Lepage:1978:vegas} to reweight the contributions as in the following improved formulae, which we might implement as an option later. \begin{subequations} \begin{align} \bar I &= \frac{1}{\left(\sum_i\frac{I_i^2}{\sigma_i^2}\right)^2} \sum_i I_i \frac{I_i^2}{\sigma_i^2} \\ \frac{1}{\sigma_I^2} &= \frac{1}{(\bar I)^2} \sum_i \frac{I_i^2}{\sigma_i^2} \\ \chi^2 &= \sum_i \frac{(I_i-\bar I)^2}{(\bar I)^2} \frac{I_i^2}{\sigma_i^2} \end{align} \end{subequations} @ Iff possible, copy the result to the caller's variables: <>= if (present (integral)) then integral = local_integral end if if (present (std_dev)) then std_dev = local_std_dev end if if (present (avg_chi2)) then avg_chi2 = local_avg_chi2 end if @ %def local_integral local_std_dev local_avg_chi2 @ %def integral std_dev avg_chi2 @ <>= if (present (accuracy)) then if (local_std_dev <= accuracy * local_integral) then call raise_exception (exc, EXC_INFO, FN, & "requested accuracy reached") exit iterate end if end if @ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Forking and Joining} <>= public :: vamp_fork_grid private :: vamp_fork_grid_single, vamp_fork_grid_multi public :: vamp_join_grid private :: vamp_join_grid_single, vamp_join_grid_multi @ %def vamp_fork_grid vamp_join_grid -@ +@ <>= interface vamp_fork_grid module procedure vamp_fork_grid_single, vamp_fork_grid_multi end interface interface vamp_join_grid module procedure vamp_join_grid_single, vamp_join_grid_multi end interface @ %def vamp_fork_grid vamp_join_grid @ Caveat emptor: splitting divisions can lead to $[[num_div]]<3$ an the application must not try to refine such grids before merging them again! [[d == 0]] is special. <>= pure subroutine vamp_fork_grid_single (g, gs, d, exc) type(vamp_grid), intent(in) :: g type(vamp_grid), dimension(:), intent(inout) :: gs integer, intent(in) :: d type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "vamp_fork_grid_single" type(division_t), dimension(:), allocatable :: d_tmp integer :: i, j, num_grids, num_div, ndim, num_cells num_grids = size (gs) ndim = size (g%div) <> do j = 1, ndim if (j == d) then <<[[call fork_division (g%div(j), gs%div(j), g%calls_per_cell, ...)]]>> else <<[[call copy_division (gs%div(j), g%div(j))]]>> end if end do if (d == 0) then <> end if <> end subroutine vamp_fork_grid_single @ %def vamp_fork_grid_single @ Divide the sampling points among identical grids <>= if (any (stratified_division (g%div))) then call raise_exception (exc, EXC_FATAL, FN, & "d == 0 incompatiple w/ stratification") else gs(2:)%calls_per_cell = ceiling (real (g%calls_per_cell) / num_grids) gs(1)%calls_per_cell = g%calls_per_cell - sum (gs(2:)%calls_per_cell) end if @ <>= do i = 1, num_grids call copy_array_pointer (gs(i)%num_div, g%num_div) if (associated (g%map)) then call copy_array_pointer (gs(i)%map, g%map) end if if (associated (g%mu_x)) then call create_array_pointer (gs(i)%mu_x, ndim) call create_array_pointer (gs(i)%sum_mu_x, ndim) call create_array_pointer (gs(i)%mu_xx, (/ ndim, ndim /)) call create_array_pointer (gs(i)%sum_mu_xx, (/ ndim, ndim /)) end if end do @ Reset results <>= gs%mu(1) = 0.0 gs%mu(2) = 0.0 gs%mu_plus(1) = 0.0 gs%mu_plus(2) = 0.0 gs%mu_minus(1) = 0.0 gs%mu_minus(2) = 0.0 gs%sum_integral = 0.0 gs%sum_weights = 0.0 gs%sum_chi2 = 0.0 gs%mu_gi = 0.0 gs%sum_mu_gi = 0.0 @ <>= gs%stratified = g%stratified gs%all_stratified = g%all_stratified gs%quadrupole = g%quadrupole @ <>= do i = 1, num_grids num_cells = product (rigid_division (gs(i)%div)) gs(i)%calls = gs(i)%calls_per_cell * num_cells gs(i)%num_calls = gs(i)%calls gs(i)%jacobi = product (volume_division (gs(i)%div)) / gs(i)%calls gs(i)%dv2g = (gs(i)%calls / num_cells)**2 & / gs(i)%calls_per_cell / gs(i)%calls_per_cell / (gs(i)%calls_per_cell - 1.0) end do gs%f_min = g%f_min * (gs%jacobi * gs%calls) / (g%jacobi * g%calls) gs%f_max = g%f_max * (gs%jacobi * gs%calls) / (g%jacobi * g%calls) @ This could be self-explaining, if the standard would allow \ldots. Note that we can get away with copying just the pointers, because [[fork_division]] does the dirty work for the memory management. <<[[call fork_division (g%div(j), gs%div(j), g%calls_per_cell, ...)]]>>= allocate (d_tmp(num_grids)) do i = 1, num_grids d_tmp(i) = gs(i)%div(j) end do call fork_division (g%div(j), d_tmp, g%calls_per_cell, gs%calls_per_cell, exc) do i = 1, num_grids gs(i)%div(j) = d_tmp(i) end do deallocate (d_tmp) <> -@ +@ <>= if (present (exc)) then if (exc%level > EXC_WARN) then return end if end if @ We have to do a deep copy ([[gs(i)%div(j) = g%div(j)]] does not suffice), because [[copy_division]] handles the memory management. <<[[call copy_division (gs%div(j), g%div(j))]]>>= do i = 1, num_grids call copy_division (gs(i)%div(j), g%div(j)) end do -@ +@ <>= num_div = size (g%div) do i = 1, size (gs) if (associated (gs(i)%div)) then if (size (gs(i)%div) /= num_div) then allocate (gs(i)%div(num_div)) call create_empty_division (gs(i)%div) end if else allocate (gs(i)%div(num_div)) call create_empty_division (gs(i)%div) end if end do -@ +@ <>= pure subroutine vamp_join_grid_single (g, gs, d, exc) type(vamp_grid), intent(inout) :: g type(vamp_grid), dimension(:), intent(inout) :: gs integer, intent(in) :: d type(exception), intent(inout), optional :: exc type(division_t), dimension(:), allocatable :: d_tmp integer :: i, j, num_grids num_grids = size (gs) do j = 1, size (g%div) if (j == d) then <<[[call join_division (g%div(j), gs%div(j))]]>> else <<[[call sum_division (g%div(j), gs%div(j))]]>> end if end do <> end subroutine vamp_join_grid_single @ %def vamp_join_grid_single -@ +@ <<[[call join_division (g%div(j), gs%div(j))]]>>= allocate (d_tmp(num_grids)) do i = 1, num_grids d_tmp(i) = gs(i)%div(j) end do call join_division (g%div(j), d_tmp, exc) deallocate (d_tmp) <> @ <<[[call sum_division (g%div(j), gs%div(j))]]>>= allocate (d_tmp(num_grids)) do i = 1, num_grids d_tmp(i) = gs(i)%div(j) end do call sum_division (g%div(j), d_tmp) deallocate (d_tmp) -@ +@ <>= g%f_min = minval (gs%f_min * (g%jacobi * g%calls) / (gs%jacobi * gs%calls)) g%f_max = maxval (gs%f_max * (g%jacobi * g%calls) / (gs%jacobi * gs%calls)) g%mu(1) = sum (gs%mu(1)) g%mu(2) = sum (gs%mu(2)) g%mu_plus(1) = sum (gs%mu_plus(1)) g%mu_plus(2) = sum (gs%mu_plus(2)) g%mu_minus(1) = sum (gs%mu_minus(1)) g%mu_minus(2) = sum (gs%mu_minus(2)) g%mu_gi = sum (gs%mu_gi) g%sum_mu_gi = g%sum_mu_gi + g%mu_gi / g%mu(2) g%sum_integral = g%sum_integral + g%mu(1) / g%mu(2) g%sum_chi2 = g%sum_chi2 + g%mu(1)**2 / g%mu(2) g%sum_weights = g%sum_weights + 1.0 / g%mu(2) if (associated (g%mu_x)) then do i = 1, num_grids g%mu_x = g%mu_x + gs(i)%mu_x g%mu_xx = g%mu_xx + gs(i)%mu_xx end do g%sum_mu_x = g%sum_mu_x + g%mu_x / g%mu(2) g%sum_mu_xx = g%sum_mu_xx + g%mu_xx / g%mu(2) end if @ The following is made a little bit hairy by the fact that [[vamp_fork_grid]] can't join grids onto a non-existing grid\footnote{It would be possible to make it possible by changing many things under the hood, but it doesn't really make sense, anyway.} therefore we have to keep a tree of joints. Maybe it would be the right thing to handle this tree of joints as a tree with pointers, but since we need the leaves flattened anyway (as food for multiple [[vamp_sample_grid]]) we use a similar storage layout for the joints. <>= type(vamp_grid), dimension(:), allocatable :: gx integer, dimension(:,:), allocatable :: dim ... allocate (gx(vamp_fork_grid_joints (dim))) call vamp_fork_grid (g, gs, gx, dim, exc) ... call vamp_join_grid (g, gs, gx, dim, exc) -@ +@ <>= pure recursive subroutine vamp_fork_grid_multi (g, gs, gx, d, exc) type(vamp_grid), intent(in) :: g type(vamp_grid), dimension(:), intent(inout) :: gs, gx integer, dimension(:,:), intent(in) :: d type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "vamp_fork_grid_multi" integer :: i, offset, stride, joints_offset, joints_stride select case (size (d, dim=2)) case (0) return case (1) call vamp_fork_grid_single (g, gs, d(1,1), exc) case default offset = 1 stride = product (d(2,2:)) joints_offset = 1 + d(2,1) joints_stride = vamp_fork_grid_joints (d(:,2:)) call vamp_create_empty_grid (gx(1:d(2,1))) call vamp_fork_grid_single (g, gx(1:d(2,1)), d(1,1), exc) do i = 1, d(2,1) call vamp_fork_grid_multi & (gx(i), gs(offset:offset+stride-1), & gx(joints_offset:joints_offset+joints_stride-1), & d(:,2:), exc) offset = offset + stride joints_offset = joints_offset + joints_stride end do end select end subroutine vamp_fork_grid_multi @ %def vamp_fork_grid_multi -@ +@ <>= public :: vamp_fork_grid_joints @ \begin{equation} \label{eq:num_joints} \sum_{n=1}^{N-1} \prod_{i_n=1}^{n} d_{i_n} = d_1(1+d_2(1+d_3(1+\ldots(1+d_{N-1})\ldots))) \end{equation} <>= pure function vamp_fork_grid_joints (d) result (s) integer, dimension(:,:), intent(in) :: d integer :: s integer :: i s = 0 do i = size (d, dim=2) - 1, 1, -1 s = (s + 1) * d(2,i) end do end function vamp_fork_grid_joints @ %def vamp_fork_grid_joints -@ +@ <>= pure recursive subroutine vamp_join_grid_multi (g, gs, gx, d, exc) type(vamp_grid), intent(inout) :: g type(vamp_grid), dimension(:), intent(inout) :: gs, gx integer, dimension(:,:), intent(in) :: d type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "vamp_join_grid_multi" integer :: i, offset, stride, joints_offset, joints_stride select case (size (d, dim=2)) case (0) return case (1) call vamp_join_grid_single (g, gs, d(1,1), exc) case default offset = 1 stride = product (d(2,2:)) joints_offset = 1 + d(2,1) joints_stride = vamp_fork_grid_joints (d(:,2:)) do i = 1, d(2,1) call vamp_join_grid_multi & (gx(i), gs(offset:offset+stride-1), & gx(joints_offset:joints_offset+joints_stride-1), & d(:,2:), exc) offset = offset + stride joints_offset = joints_offset + joints_stride end do call vamp_join_grid_single (g, gx(1:d(2,1)), d(1,1), exc) call vamp_delete_grid (gx(1:d(2,1))) end select end subroutine vamp_join_grid_multi @ %def vamp_join_grid_multi @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Parallel Execution} <>= public :: vamp_sample_grid_parallel public :: vamp_distribute_work @ HPF~\cite{HPF1.1,HPF2.0,Koelbel/etal:1994:HPF}: <>= subroutine vamp_sample_grid_parallel & (rng, g, func, data, iterations, & integral, std_dev, avg_chi2, accuracy, & channel, weights, grids, exc, history) type(tao_random_state), dimension(:), intent(inout) :: rng type(vamp_grid), intent(inout) :: g class(vamp_data_t), intent(in) :: data integer, intent(in) :: iterations real(kind=default), intent(out), optional :: integral, std_dev, avg_chi2 real(kind=default), intent(in), optional :: accuracy integer, intent(in), optional :: channel real(kind=default), dimension(:), intent(in), optional :: weights type(vamp_grid), dimension(:), intent(in), optional :: grids type(exception), intent(inout), optional :: exc type(vamp_history), dimension(:), intent(inout), optional :: history <> character(len=*), parameter :: FN = "vamp_sample_grid_parallel" real(kind=default) :: local_integral, local_std_dev, local_avg_chi2 type(exception), dimension(size(rng)) :: excs type(vamp_grid), dimension(:), allocatable :: gs, gx !hpf$ processors p(number_of_processors()) !hpf$ distribute gs(cyclic(1)) onto p integer, dimension(:,:), pointer :: d integer :: iteration, i integer :: num_workers nullify (d) call clear_exception (excs) iterate: do iteration = 1, iterations call vamp_distribute_work (size (rng), vamp_rigid_divisions (g), d) num_workers = max (1, product (d(2,:))) if (num_workers > 1) then allocate (gs(num_workers), gx(vamp_fork_grid_joints (d))) call vamp_create_empty_grid (gs) !: \texttt{vamp\_fork\_grid} is certainly not local. Speed freaks might !: want to tune it to the processor topology, but the gain will be small. call vamp_fork_grid (g, gs, gx, d, exc) !hpf$ independent do i = 1, num_workers call vamp_sample_grid0 & (rng(i), gs(i), func, data, & channel, weights, grids, exc) end do <> call vamp_join_grid (g, gs, gx, d, exc) call vamp_delete_grid (gs) deallocate (gs, gx) else call vamp_sample_grid0 & (rng(1), g, func, data, channel, weights, grids, exc) end if <> call vamp_average_iterations & (g, iteration, local_integral, local_std_dev, local_avg_chi2) <> <> if (iteration < iterations) call vamp_refine_grid (g) end do iterate deallocate (d) <> end subroutine vamp_sample_grid_parallel @ %def vamp_sample_grid_parallel -@ +@ <>= if ((present (exc)) .and. (any (excs(1:num_workers)%level > 0))) then call gather_exceptions (exc, excs(1:num_workers)) end if @ We could sort~$d$ such that~(\ref{eq:num_joints}) is minimized \index{optimizations not implemented yet} \begin{equation} d_1 \le d_2 \le \ldots \le d_N \end{equation} but the gain will be negligible. <>= pure subroutine vamp_distribute_work (num_workers, ng, d) integer, intent(in) :: num_workers integer, dimension(:), intent(in) :: ng integer, dimension(:,:), pointer :: d integer, dimension(32) :: factors integer :: n, num_factors, i, j integer, dimension(size(ng)) :: num_forks integer :: nfork try: do n = num_workers, 1, -1 call factorize (n, factors, num_factors) num_forks = 1 do i = num_factors, 1, -1 j = sum (maxloc (ng / num_forks)) nfork = num_forks(j) * factors(i) if (nfork <= ng(j)) then num_forks(j) = nfork else cycle try end if end do <> end do try end subroutine vamp_distribute_work -@ +@ <>= j = count (num_forks > 1) if (associated (d)) then if (size (d, dim = 2) /= j) then deallocate (d) allocate (d(2,j)) end if else allocate (d(2,j)) end if -@ +@ <>= j = 1 do i = 1, size (ng) if (num_forks(i) > 1) then d(:,j) = (/ i, num_forks(i) /) j = j + 1 end if end do return -@ +@ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Diagnostics} <>= type, public :: vamp_history private real(kind=default) :: & integral, std_dev, avg_integral, avg_std_dev, avg_chi2, f_min, f_max integer :: calls logical :: stratified logical :: verbose type(div_history), dimension(:), pointer :: div => null () end type vamp_history @ %def vamp_history -@ +@ <>= if (present (history)) then if (iteration <= size (history)) then call vamp_get_history & (history(iteration), g, local_integral, local_std_dev, & local_avg_chi2) else call raise_exception (exc, EXC_WARN, FN, "history too short") end if call vamp_terminate_history (history(iteration+1:)) end if @ <>= public :: vamp_create_history, vamp_copy_history, vamp_delete_history public :: vamp_terminate_history public :: vamp_get_history, vamp_get_history_single @ <>= interface vamp_get_history module procedure vamp_get_history_single end interface -@ +@ <>= elemental subroutine vamp_create_history (h, ndim, verbose) type(vamp_history), intent(out) :: h integer, intent(in), optional :: ndim logical, intent(in), optional :: verbose if (present (verbose)) then h%verbose = verbose else h%verbose = .false. end if h%calls = 0.0 if (h%verbose .and. (present (ndim))) then if (associated (h%div)) then deallocate (h%div) end if allocate (h%div(ndim)) end if end subroutine vamp_create_history @ %def vamp_create_history -@ +@ <>= elemental subroutine vamp_terminate_history (h) type(vamp_history), intent(inout) :: h h%calls = 0.0 end subroutine vamp_terminate_history @ %def vamp_terminate_history -@ +@ <>= pure subroutine vamp_get_history_single (h, g, integral, std_dev, avg_chi2) type(vamp_history), intent(inout) :: h type(vamp_grid), intent(in) :: g real(kind=default), intent(in) :: integral, std_dev, avg_chi2 h%calls = g%calls h%stratified = g%all_stratified h%integral = g%mu(1) h%std_dev = sqrt (g%mu(2)) h%avg_integral = integral h%avg_std_dev = std_dev h%avg_chi2 = avg_chi2 h%f_min = g%f_min h%f_max = g%f_max if (h%verbose) then <> call copy_history (h%div, summarize_division (g%div)) end if end subroutine vamp_get_history_single @ %def vamp_get_history_single @ <>= if (associated (h%div)) then if (size (h%div) /= size (g%div)) then deallocate (h%div) allocate (h%div(size(g%div))) end if else allocate (h%div(size(g%div))) end if -@ +@ <>= public :: vamp_print_history, vamp_write_history private :: vamp_print_one_history, vamp_print_histories ! private :: vamp_write_one_history, vamp_write_histories @ %def vamp_print_history vamp_print_one_history vamp_print_histories @ %def vamp_write_history vamp_write_one_history vamp_write_histories @ <>= interface vamp_print_history module procedure vamp_print_one_history, vamp_print_histories end interface interface vamp_write_history module procedure vamp_write_one_history_unit, vamp_write_histories_unit end interface @ %def vamp_print_history @ %def vamp_write_history -@ +@ <>= subroutine vamp_print_one_history (h, tag) type(vamp_history), dimension(:), intent(in) :: h character(len=*), intent(in), optional :: tag type(div_history), dimension(:), allocatable :: h_tmp character(len=BUFFER_SIZE) :: pfx character(len=1) :: s integer :: i, imax, j if (present (tag)) then pfx = tag else pfx = "[vamp]" end if print "(1X,A78)", repeat ("-", 78) print "(1X,A8,1X,A2,A9,A1,1X,A11,1X,8X,1X," & // "1X,A13,1X,8X,1X,A5,1X,A5)", & pfx, "it", "#calls", "", "integral", "average", "chi2", "eff." imax = size (h) iterations: do i = 1, imax if (h(i)%calls <= 0) then imax = i - 1 exit iterations end if ! *JR: Skip zero channel if (h(i)%f_max==0) cycle if (h(i)%stratified) then s = "*" else s = "" end if print "(1X,A8,1X,I2,I9,A1,1X,E11.4,A1,E8.2,A1," & // "1X,E13.6,A1,E8.2,A1,F5.1,1X,F5.3)", pfx, & i, h(i)%calls, s, h(i)%integral, "(", h(i)%std_dev, ")", & h(i)%avg_integral, "(", h(i)%avg_std_dev, ")", h(i)%avg_chi2, & h(i)%integral / h(i)%f_max end do iterations print "(1X,A78)", repeat ("-", 78) if (all (h%verbose) .and. (imax >= 1)) then if (associated (h(1)%div)) then allocate (h_tmp(imax)) dimensions: do j = 1, size (h(1)%div) do i = 1, imax call copy_history (h_tmp(i), h(i)%div(j)) end do if (present (tag)) then write (unit = pfx, fmt = "(A,A1,I2.2)") & trim (tag(1:min(len_trim(tag),8))), "#", j else write (unit = pfx, fmt = "(A,A1,I2.2)") "[vamp]", "#", j end if call print_history (h_tmp, tag = pfx) print "(1X,A78)", repeat ("-", 78) end do dimensions deallocate (h_tmp) end if end if flush (output_unit) end subroutine vamp_print_one_history @ %def vamp_print_one_history -@ +@ <>= integer, private, parameter :: BUFFER_SIZE = 50 @ %def BUFFER_SIZE -@ +@ <>= subroutine vamp_print_histories (h, tag) type(vamp_history), dimension(:,:), intent(in) :: h character(len=*), intent(in), optional :: tag character(len=BUFFER_SIZE) :: pfx integer :: i print "(1X,A78)", repeat ("=", 78) channels: do i = 1, size (h, dim=2) if (present (tag)) then write (unit = pfx, fmt = "(A4,A1,I3.3)") tag, "#", i else write (unit = pfx, fmt = "(A4,A1,I3.3)") "chan", "#", i end if call vamp_print_one_history (h(:,i), pfx) end do channels print "(1X,A78)", repeat ("=", 78) flush (output_unit) end subroutine vamp_print_histories @ %def vamp_print_histories -@ +@ \begin{dubious} WK \end{dubious} <>= subroutine vamp_write_one_history_unit (u, h, tag) integer, intent(in) :: u type(vamp_history), dimension(:), intent(in) :: h character(len=*), intent(in), optional :: tag type(div_history), dimension(:), allocatable :: h_tmp character(len=BUFFER_SIZE) :: pfx character(len=1) :: s integer :: i, imax, j if (present (tag)) then pfx = tag else pfx = "[vamp]" end if write (u, "(1X,A78)") repeat ("-", 78) write (u, "(1X,A8,1X,A2,A9,A1,1X,A11,1X,8X,1X," & // "1X,A13,1X,8X,1X,A5,1X,A5)") & pfx, "it", "#calls", "", "integral", "average", "chi2", "eff." imax = size (h) iterations: do i = 1, imax if (h(i)%calls <= 0) then imax = i - 1 exit iterations end if ! *WK: Skip zero channel if (h(i)%f_max==0) cycle if (h(i)%stratified) then s = "*" else s = "" end if write (u, "(1X,A8,1X,I2,I9,A1,1X,ES11.4,A1,ES8.2,A1," & // "1X,ES13.6,A1,ES8.2,A1,F5.1,1X,F5.3)") pfx, & i, h(i)%calls, s, h(i)%integral, "(", h(i)%std_dev, ")", & h(i)%avg_integral, "(", h(i)%avg_std_dev, ")", h(i)%avg_chi2, & h(i)%integral / h(i)%f_max end do iterations write (u, "(1X,A78)") repeat ("-", 78) if (all (h%verbose) .and. (imax >= 1)) then if (associated (h(1)%div)) then allocate (h_tmp(imax)) dimensions: do j = 1, size (h(1)%div) do i = 1, imax call copy_history (h_tmp(i), h(i)%div(j)) end do if (present (tag)) then write (unit = pfx, fmt = "(A,A1,I2.2)") & trim (tag(1:min(len_trim(tag),8))), "#", j else write (unit = pfx, fmt = "(A,A1,I2.2)") "[vamp]", "#", j end if call write_history (u, h_tmp, tag = pfx) print "(1X,A78)", repeat ("-", 78) end do dimensions deallocate (h_tmp) end if end if flush (u) end subroutine vamp_write_one_history_unit subroutine vamp_write_histories_unit (u, h, tag) integer, intent(in) :: u type(vamp_history), dimension(:,:), intent(in) :: h character(len=*), intent(in), optional :: tag character(len=BUFFER_SIZE) :: pfx integer :: i write (u, "(1X,A78)") repeat ("=", 78) channels: do i = 1, size (h, dim=2) if (present (tag)) then write (unit = pfx, fmt = "(A4,A1,I3.3)") tag, "#", i else write (unit = pfx, fmt = "(A4,A1,I3.3)") "chan", "#", i end if call vamp_write_one_history_unit (u, h(:,i), pfx) end do channels write (u, "(1X,A78)") repeat ("=", 78) flush (u) end subroutine vamp_write_histories_unit @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Multi Channel} \cite{Kleiss/Pittau:1994:multichannel} \begin{subequations} \begin{align} \label{eq:g(x)} g(x) &= \sum_i \alpha_i g_i(x) \\ \label{eq:w(x)} w(x) &= \frac{f(x)}{g(x)} \end{align} \end{subequations} We want to minimize the variance~$W(\alpha)$ with the subsidiary condition~$\sum_i\alpha_i = 1$. We indroduce a Lagrange multiplier~$\lambda$: \begin{equation} \tilde W(\alpha) = W(\alpha) + \lambda \left(\sum_i\alpha_i - 1\right) \end{equation} Therefore\ldots \begin{equation} W_i(\alpha) = -\frac{\partial}{\partial\alpha_i} W(\alpha) = \int\!dx\, g_i(x) (w(x))^2 \approx \left\langle \frac{g_i(x)}{g(x)} (w(x))^2 \right\rangle \end{equation} \begin{dubious} \index{Fortran sucks!} \index{functional programming rules!} Here it \emph{really} hurts that \texttt{Fortran} has no \emph{first-class} functions. The following can be expressed much more elegantly in a functional programming language with \emph{first-class} functions, currying and closures. \texttt{Fortran} makes it extra painful since not even procedure pointers are supported. This puts extra burden on the users of this library. \end{dubious} Note that the components of [[vamp_grids]] are not protected. However, this is not a license for application programs to access it. Only Other libraries (e.g.~for parallel processing, like [[vampi]]) should do so. <>= type, public :: vamp_grids !!! private !: \emph{used by \texttt{vampi}} real(kind=default), dimension(:), pointer :: weights => null () type(vamp_grid), dimension(:), pointer :: grids => null () integer, dimension(:), pointer :: num_calls => null () real(kind=default) :: sum_chi2, sum_integral, sum_weights end type vamp_grids @ %def vamp_grids -@ +@ \begin{equation} \label{eq:gophi_i} g\circ\phi_i = \left|\frac{\partial\phi_i}{\partial x}\right|^{-1} - \left( \alpha_i g_i + + \left( \alpha_i g_i + \sum_{\substack{j=1\\j\not=i}}^{N_c} \alpha_j (g_j\circ\pi_{ij}) \left|\frac{\partial\pi_{ij}}{\partial x}\right| \right)\,. \end{equation} <>= public :: vamp_multi_channel, vamp_multi_channel0 @ <>= function vamp_multi_channel & (func, data, phi, ihp, jacobian, x, weights, channel, grids) result (w_x) class(vamp_data_t), intent(in) :: data real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:), intent(in) :: weights integer, intent(in) :: channel type(vamp_grid), dimension(:), intent(in) :: grids <> <> <> <> real(kind=default) :: w_x integer :: i real(kind=default), dimension(size(x)) :: phi_x real(kind=default), dimension(size(weights)) :: g_phi_x, g_pi_x phi_x = phi (x, channel) do i = 1, size (weights) if (i == channel) then g_pi_x(i) = vamp_probability (grids(i), x) else g_pi_x(i) = vamp_probability (grids(i), ihp (phi_x, i)) end if end do do i = 1, size (weights) g_phi_x(i) = g_pi_x(i) / g_pi_x(channel) * jacobian (phi_x, data, i) end do w_x = func (phi_x, data, weights, channel, grids) & / dot_product (weights, g_phi_x) end function vamp_multi_channel @ %def vamp_multi_channel -@ +@ <>= function vamp_multi_channel0 & (func, data, phi, jacobian, x, weights, channel) result (w_x) class(vamp_data_t), intent(in) :: data real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:), intent(in) :: weights integer, intent(in) :: channel <> <> <> real(kind=default) :: w_x real(kind=default), dimension(size(x)) :: x_prime real(kind=default), dimension(size(weights)) :: g_phi_x integer :: i x_prime = phi (x, channel) do i = 1, size (weights) g_phi_x(i) = jacobian (x_prime, data, i) end do w_x = func (x_prime, data) / dot_product (weights, g_phi_x) end function vamp_multi_channel0 @ %def vamp_multi_channel0 -@ +@ \begin{dubious} WK \end{dubious} <>= public :: vamp_jacobian, vamp_check_jacobian @ <>= pure subroutine vamp_jacobian (phi, channel, x, region, jacobian, delta_x) integer, intent(in) :: channel real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:,:), intent(in) :: region real(kind=default), intent(out) :: jacobian real(kind=default), intent(in), optional :: delta_x interface pure function phi (xi, channel) result (x) use kinds real(kind=default), dimension(:), intent(in) :: xi integer, intent(in) :: channel real(kind=default), dimension(size(xi)) :: x end function phi end interface real(kind=default), dimension(size(x)) :: x_min, x_max real(kind=default), dimension(size(x)) :: x_plus, x_minus real(kind=default), dimension(size(x),size(x)) :: d_phi real(kind=default), parameter :: & dx_default = 10.0_default**(-precision(jacobian)/3) real(kind=default) :: dx integer :: j if (present (delta_x)) then dx = delta_x else dx = dx_default end if x_min = region(1,:) x_max = region(2,:) x_minus = max (x_min, x) x_plus = min (x_max, x) do j = 1, size (x) x_minus(j) = max (x_min(j), x(j) - dx) x_plus(j) = min (x_max(j), x(j) + dx) d_phi(:,j) = (phi (x_plus, channel) - phi (x_minus, channel)) & / (x_plus(j) - x_minus(j)) x_minus(j) = max (x_min(j), x(j)) x_plus(j) = min (x_max(j), x(j)) end do call determinant (d_phi, jacobian) jacobian = abs (jacobian) end subroutine vamp_jacobian @ \begin{equation} g(\phi(x)) = \frac{1}{\left|\frac{\partial\phi}{\partial x}\right|(x)} \end{equation} <>= subroutine vamp_check_jacobian & (rng, n, func, data, phi, channel, region, delta, x_delta) type(tao_random_state), intent(inout) :: rng integer, intent(in) :: n class(vamp_data_t), intent(in) :: data integer, intent(in) :: channel real(kind=default), dimension(:,:), intent(in) :: region real(kind=default), intent(out) :: delta real(kind=default), dimension(:), intent(out), optional :: x_delta <> <> real(kind=default), dimension(size(region,dim=2)) :: x, r real(kind=default) :: jac, d real(kind=default), dimension(0) :: wgts integer :: i delta = 0.0 do i = 1, max (1, n) call tao_random_number (rng, r) x = region(1,:) + (region(2,:) - region(1,:)) * r call vamp_jacobian (phi, channel, x, region, jac) d = func (phi (x, channel), data, wgts, channel) * jac & - 1.0_default if (abs (d) >= abs (delta)) then delta = d if (present (x_delta)) then x_delta = x end if end if end do end subroutine vamp_check_jacobian @ %def vamp_check_jacobian @ This is a subroutine to comply with F's rules, otherwise, we would code it as a function. \index{inconvenient F constraints} <>= private :: numeric_jacobian @ <>= pure subroutine numeric_jacobian (phi, channel, x, region, jacobian, delta_x) integer, intent(in) :: channel real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:,:), intent(in) :: region real(kind=default), intent(out) :: jacobian real(kind=default), intent(in), optional :: delta_x <> real(kind=default), dimension(size(x)) :: x_min, x_max real(kind=default), dimension(size(x)) :: x_plus, x_minus real(kind=default), dimension(size(x),size(x)) :: d_phi real(kind=default), parameter :: & dx_default = 10.0_default**(-precision(jacobian)/3) real(kind=default) :: dx integer :: j if (present (delta_x)) then dx = delta_x else dx = dx_default end if x_min = region(1,:) x_max = region(2,:) x_minus = max (x_min, x) x_plus = min (x_max, x) do j = 1, size (x) x_minus(j) = max (x_min(j), x(j) - dx) x_plus(j) = min (x_max(j), x(j) + dx) d_phi(:,j) = (phi (x_plus, channel) - phi (x_minus, channel)) & / (x_plus(j) - x_minus(j)) x_minus(j) = max (x_min(j), x(j)) x_plus(j) = min (x_max(j), x(j)) end do call determinant (d_phi, jacobian) jacobian = abs (jacobian) end subroutine numeric_jacobian @ %def numeric_jacobian -@ +@ <>= public :: vamp_create_grids, vamp_create_empty_grids public :: vamp_copy_grids, vamp_delete_grids @ The rules for optional arguments forces us to handle special cases, because we can't just pass a array section of an optional array as an actual argument (cf.~12.4.1.5(4) in~\cite{Fortran95}) even if the dummy argument is optional itself. <>= pure subroutine vamp_create_grids & (g, domain, num_calls, weights, maps, num_div, & stratified, quadrupole, exc) type(vamp_grids), intent(inout) :: g real(kind=default), dimension(:,:), intent(in) :: domain integer, intent(in) :: num_calls real(kind=default), dimension(:), intent(in) :: weights real(kind=default), dimension(:,:,:), intent(in), optional :: maps integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "vamp_create_grids" integer :: ch, nch nch = size (weights) allocate (g%grids(nch), g%weights(nch), g%num_calls(nch)) g%weights = weights / sum (weights) g%num_calls = g%weights * num_calls do ch = 1, size (g%grids) if (present (maps)) then call vamp_create_grid & (g%grids(ch), domain, g%num_calls(ch), num_div, & stratified, quadrupole, map = maps(:,:,ch), exc = exc) else call vamp_create_grid & (g%grids(ch), domain, g%num_calls(ch), num_div, & stratified, quadrupole, exc = exc) end if end do g%sum_integral = 0.0 g%sum_chi2 = 0.0 g%sum_weights = 0.0 end subroutine vamp_create_grids @ %def vamp_create_grids -@ +@ <>= pure subroutine vamp_create_empty_grids (g) type(vamp_grids), intent(inout) :: g nullify (g%grids, g%weights, g%num_calls) end subroutine vamp_create_empty_grids @ %def vamp_create_empty_grids -@ +@ <>= public :: vamp_discard_integrals @ <>= pure subroutine vamp_discard_integrals & (g, num_calls, num_div, stratified, quadrupole, exc, eq) type(vamp_grids), intent(inout) :: g integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole type(exception), intent(inout), optional :: exc type(vamp_equivalences_t), intent(in), optional :: eq integer :: ch character(len=*), parameter :: FN = "vamp_discard_integrals" g%sum_integral = 0.0 g%sum_weights = 0.0 g%sum_chi2 = 0.0 do ch = 1, size (g%grids) call vamp_discard_integral (g%grids(ch)) end do if (present (num_calls)) then call vamp_reshape_grids & (g, num_calls, num_div, stratified, quadrupole, exc, eq) end if end subroutine vamp_discard_integrals @ %def vamp_discard_integrals @ %def sum_integral sum_weights sum_chi2 -@ +@ <>= public :: vamp_update_weights @ We must discard the accumulated integrals, because the weight function~$w=f/\sum_i\alpha_ig_i$ changes: <>= pure subroutine vamp_update_weights & (g, weights, num_calls, num_div, stratified, quadrupole, exc) type(vamp_grids), intent(inout) :: g real(kind=default), dimension(:), intent(in) :: weights integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "vamp_update_weights" if (sum (weights) > 0) then g%weights = weights / sum (weights) else g%weights = 1._default / size(g%weights) end if if (present (num_calls)) then call vamp_discard_integrals (g, num_calls, num_div, & stratified, quadrupole, exc) else call vamp_discard_integrals (g, sum (g%num_calls), num_div, & stratified, quadrupole, exc) end if end subroutine vamp_update_weights @ %def vamp_update_weights -@ +@ <>= public :: vamp_reshape_grids @ <>= pure subroutine vamp_reshape_grids & (g, num_calls, num_div, stratified, quadrupole, exc, eq) type(vamp_grids), intent(inout) :: g integer, intent(in) :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole type(exception), intent(inout), optional :: exc type(vamp_equivalences_t), intent(in), optional :: eq integer, dimension(size(g%grids(1)%num_div)) :: num_div_new integer :: ch character(len=*), parameter :: FN = "vamp_reshape_grids" g%num_calls = g%weights * num_calls do ch = 1, size (g%grids) if (g%num_calls(ch) >= 2) then if (present (eq)) then if (present (num_div)) then num_div_new = num_div else num_div_new = g%grids(ch)%num_div end if where (eq%div_is_invariant(ch,:)) num_div_new = 1 end where call vamp_reshape_grid (g%grids(ch), g%num_calls(ch), & num_div_new, stratified, quadrupole, exc = exc, & independent = eq%independent(ch), & equivalent_to_ch = eq%equivalent_to_ch(ch), & multiplicity = eq%multiplicity(ch)) else call vamp_reshape_grid (g%grids(ch), g%num_calls(ch), & num_div, stratified, quadrupole, exc = exc) end if else g%num_calls(ch) = 0 end if end do end subroutine vamp_reshape_grids @ %def vamp_reshape_grids -@ +@ <>= public :: vamp_sample_grids @ Even if [[g%num_calls]] is derived from [[g%weights]], we must \emph{not} use the latter, allow for integer arithmetic in [[g%num_calls]].\par <>= subroutine vamp_sample_grids & (rng, g, func, data, iterations, integral, std_dev, avg_chi2, & accuracy, history, histories, exc, eq, warn_error, negative_weights) type(tao_random_state), intent(inout) :: rng type(vamp_grids), intent(inout) :: g class(vamp_data_t), intent(in) :: data integer, intent(in) :: iterations real(kind=default), intent(out), optional :: integral, std_dev, avg_chi2 real(kind=default), intent(in), optional :: accuracy type(vamp_history), dimension(:), intent(inout), optional :: history type(vamp_history), dimension(:,:), intent(inout), optional :: histories type(exception), intent(inout), optional :: exc type(vamp_equivalences_t), intent(in), optional :: eq logical, intent(in), optional :: warn_error, negative_weights <> integer :: ch, iteration logical :: neg_w type(exception), dimension(size(g%grids)) :: excs logical, dimension(size(g%grids)) :: active real(kind=default), dimension(size(g%grids)) :: weights, integrals, std_devs real(kind=default) :: local_integral, local_std_dev, local_avg_chi2 character(len=*), parameter :: FN = "vamp_sample_grids" integrals = 0 std_devs = 0 neg_w = .false. if (present (negative_weights)) neg_w = negative_weights active = (g%num_calls >= 2) where (active) weights = g%num_calls elsewhere weights = 0.0 endwhere if (sum (weights) /= 0) weights = weights / sum (weights) call clear_exception (excs) iterate: do iteration = 1, iterations do ch = 1, size (g%grids) if (active(ch)) then call vamp_discard_integral (g%grids(ch)) <> else call vamp_nullify_variance (g%grids(ch)) call vamp_nullify_covariance (g%grids(ch)) end if end do if (present(eq)) call vamp_apply_equivalences (g, eq) if (iteration < iterations) then do ch = 1, size (g%grids) active(ch) = (integrals(ch) /= 0) if (active(ch)) then call vamp_refine_grid (g%grids(ch)) end if end do end if if (present (exc) .and. (any (excs%level > 0))) then call gather_exceptions (exc, excs) ! return end if call vamp_reduce_channels (g, integrals, std_devs, active) call vamp_average_iterations & (g, iteration, local_integral, local_std_dev, local_avg_chi2) <> <> end do iterate <> end subroutine vamp_sample_grids @ %def vamp_sample_grids @ We must refine the grids after \emph{all} grids have been sampled, therefore we use [[vamp_sample_grid0]] instead of [[vamp_sample_grid]]: <>= call vamp_sample_grid0 & (rng, g%grids(ch), func, data, & ch, weights, g%grids, excs(ch), neg_w) if (present (exc) .and. present (warn_error)) then if (warn_error) call handle_exception (excs(ch)) end if call vamp_average_iterations & (g%grids(ch), iteration, integrals(ch), std_devs(ch), local_avg_chi2) if (present (histories)) then if (iteration <= ubound (histories, dim=1)) then call vamp_get_history & (histories(iteration,ch), g%grids(ch), & integrals(ch), std_devs(ch), local_avg_chi2) else call raise_exception (exc, EXC_WARN, FN, "history too short") end if call vamp_terminate_history (histories(iteration+1:,ch)) end if -@ +@ <>= public :: vamp_reduce_channels @ \begin{subequations} \begin{align} I &= \frac{1}{N} \sum_c N_c I_c \\ \label{eq:multi-sigma} \sigma^2 &= \frac{1}{N^2} \sum_c N_c^2 \sigma_c^2 \\ N & = \sum_c N_c \end{align} \end{subequations} where~(\ref{eq:multi-sigma}) is actually \begin{equation*} \sigma^2 = \frac{1}{N}\left(\mu_2 - \mu_1^1\right) = \frac{1}{N}\left(\frac{1}{N} \sum_c N_c \mu_{2,c} - I^2\right) = \frac{1}{N}\left(\frac{1}{N} \sum_c (N_c^2 \sigma_c^2 + N_c I_c^2) - I^2\right) \end{equation*} but the latter form suffers from numerical instability and~(\ref{eq:multi-sigma}) is thus preferred. <>= pure subroutine vamp_reduce_channels (g, integrals, std_devs, active) type(vamp_grids), intent(inout) :: g real(kind=default), dimension(:), intent(in) :: integrals, std_devs logical, dimension(:), intent(in) :: active real(kind=default) :: this_integral, this_weight, total_calls real(kind=default) :: total_variance if (.not.any(active)) return total_calls = sum (g%num_calls, mask=active) if (total_calls > 0) then this_integral = sum (g%num_calls * integrals, mask=active) / total_calls else this_integral = 0 end if total_variance = sum ((g%num_calls*std_devs)**2, mask=active) if (total_variance > 0) then this_weight = total_calls**2 / total_variance else this_weight = 0 end if g%sum_weights = g%sum_weights + this_weight g%sum_integral = g%sum_integral + this_weight * this_integral g%sum_chi2 = g%sum_chi2 + this_weight * this_integral**2 end subroutine vamp_reduce_channels @ %def vamp_reduce_channels -@ +@ <>= public :: vamp_refine_weights -@ +@ <>= elemental subroutine vamp_average_iterations_grids & (g, iteration, integral, std_dev, avg_chi2) type(vamp_grids), intent(in) :: g integer, intent(in) :: iteration real(kind=default), intent(out) :: integral, std_dev, avg_chi2 real(kind=default), parameter :: eps = 1000 * epsilon (1._default) if (g%sum_weights>0) then integral = g%sum_integral / g%sum_weights std_dev = sqrt (1.0 / g%sum_weights) avg_chi2 = & max ((g%sum_chi2 - g%sum_integral * integral) / (iteration-0.99), & 0.0_default) if (avg_chi2 < eps * g%sum_chi2) avg_chi2 = 0 else integral = 0 std_dev = 0 avg_chi2 = 0 end if end subroutine vamp_average_iterations_grids @ %def vamp_average_iterations_grids -@ +@ <>= private :: vamp_average_iterations_grids -@ +@ <>= interface vamp_average_iterations module procedure vamp_average_iterations_grids end interface @ %def vamp_average_iterations @ \begin{equation} \alpha_i \to \alpha_i \sqrt{V_i} \end{equation} <>= pure subroutine vamp_refine_weights (g, power) type(vamp_grids), intent(inout) :: g real(kind=default), intent(in), optional :: power - real(kind=default) :: local_power + real(kind=default) :: local_power real(kind=default), parameter :: DEFAULT_POWER = 0.5_default if (present (power)) then local_power = power else local_power = DEFAULT_POWER end if call vamp_update_weights & (g, g%weights * vamp_get_variance (g%grids) ** local_power) end subroutine vamp_refine_weights @ %def vamp_refine_weights -@ +@ <>= if (present (history)) then if (iteration <= size (history)) then call vamp_get_history & (history(iteration), g, local_integral, local_std_dev, & local_avg_chi2) else call raise_exception (exc, EXC_WARN, FN, "history too short") end if call vamp_terminate_history (history(iteration+1:)) end if @ <>= private :: vamp_get_history_multi @ <>= interface vamp_get_history module procedure vamp_get_history_multi end interface -@ +@ <>= pure subroutine vamp_get_history_multi (h, g, integral, std_dev, avg_chi2) type(vamp_history), intent(inout) :: h type(vamp_grids), intent(in) :: g real(kind=default), intent(in) :: integral, std_dev, avg_chi2 h%calls = sum (g%grids%calls) h%stratified = all (g%grids%all_stratified) h%integral = 0.0 h%std_dev = 0.0 h%avg_integral = integral h%avg_std_dev = std_dev h%avg_chi2 = avg_chi2 h%f_min = 0.0 h%f_max = huge (h%f_max) if (h%verbose) then h%verbose = .false. if (associated (h%div)) then deallocate (h%div) end if end if end subroutine vamp_get_history_multi @ %def vamp_get_history_multi @ \begin{dubious} WK \end{dubious} @ <>= public :: vamp_sum_channels @ <>= function vamp_sum_channels (x, weights, func, data, grids) result (g) real(kind=default), dimension(:), intent(in) :: x, weights class(vamp_data_t), intent(in) :: data type(vamp_grid), dimension(:), intent(in), optional :: grids interface function func (xi, data, weights, channel, grids) result (f) use kinds use vamp_grid_type !NODEP! import vamp_data_t real(kind=default), dimension(:), intent(in) :: xi class(vamp_data_t), intent(in) :: data real(kind=default), dimension(:), intent(in), optional :: weights integer, intent(in), optional :: channel type(vamp_grid), dimension(:), intent(in), optional :: grids real(kind=default) :: f end function func end interface real(kind=default) :: g integer :: ch g = 0.0 do ch = 1, size (weights) g = g + weights(ch) * func (x, data, weights, ch, grids) end do end function vamp_sum_channels @ %def vamp_sum_channels @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Mapping} \begin{dubious} \index{unfinished business} This section is still under construction. The basic algorithm is in place, but the heuristics have not be developed yet. \end{dubious} The most naive approach is to use the rotation matrix~$R$ that diagonalizes the covariance~$C$: \begin{equation} R_{ij} = (v_j)_i \end{equation} where \begin{equation} C v_j = \lambda_j v_j \end{equation} with the eigenvalues~$\{\lambda_j\}$ and eigenvectors~$\{v_j\}$. Then \begin{equation} R^T C R = \mathop{\textrm{diag}} (\lambda_1,\ldots) \end{equation} After [[call diagonalize_real_symmetric (cov, evals, evecs)]], we have $\text{[[evals]]}(j)=\lambda_j$ and $\text{[[evecs]]}(\text{[[:]]},j)=v_j$. This is equivalent with $\text{[[evecs]]}(i,j)=R_{ij}$.\par This approach will not work in high dimensions, however. In general,~$R$ will \emph{not} leave most of the axes invariant, even if the covariance matrix is almost isotripic in these directions. I this case the benefit from the rotation is rather small and offset by the negative effects from the misalignment of the integration region.\par A better strategy is to find the axis of the original coordinate system around which a rotation is most beneficial. There are two extreme cases: \begin{itemize} \item ``pancake'': one eigenvalue much smaller than the others \item ``cigar'': one eigenvalue much larger than the others \end{itemize} Actually, instead of rotating around a specfic axis, we can as well diagonalize in a subspace. Empirically, rotation around an axis is better than diagonalizing in a two-dimensional subspace, but diagonalizing in a three-dimensional subspace can be even better. <>= public :: select_rotation_axis public :: select_rotation_subspace @ %def select_rotation_axis @ %def select_rotation_subspace @ <>= if (num_pancake > 0) then print *, "FORCED PANCAKE: ", num_pancake iv = sum (minloc (evals)) else if (num_cigar > 0) then print *, "FORCED CIGAR: ", num_cigar iv = sum (maxloc (evals)) else call more_pancake_than_cigar (evals, like_pancake) if (like_pancake) then iv = sum (minloc (evals)) else iv = sum (maxloc (evals)) end if end if @ %def iv @ <>= subroutine more_pancake_than_cigar (eval, yes_or_no) real(kind=default), dimension(:), intent(in) :: eval logical, intent(out) :: yes_or_no integer, parameter :: N_CL = 2 real(kind=default), dimension(size(eval)) :: evals real(kind=default), dimension(N_CL) :: cluster_pos integer, dimension(N_CL,2) :: clusters evals = eval call sort (evals) call condense (evals, cluster_pos, clusters) print *, clusters(1,2) - clusters(1,1) + 1, "small EVs: ", & evals(clusters(1,1):clusters(1,2)) print *, clusters(2,2) - clusters(2,1) + 1, "large EVs: ", & evals(clusters(2,1):clusters(2,2)) if ((clusters(1,2) - clusters(1,1)) & < (clusters(2,2) - clusters(2,1))) then print *, " => PANCAKE!" yes_or_no = .true. else print *, " => CIGAR!" yes_or_no = .false. end if end subroutine more_pancake_than_cigar @ %def more_pancake_than_cigar -@ +@ <>= private :: more_pancake_than_cigar @ %def more_pancake_than_cigar @ In both cases, we can rotate in the plane~$P_{ij}$ closest to eigenvector corresponding to the the singled out eigenvalue. This plane is given by \begin{equation} \max_{i\not= i'} \sqrt{(v_j)_i^2 + (v_j)_{i'}^2} \end{equation} which is simply found by looking for the two largest~$|(v_j)_i|$:\footnote{The [[sum]] intrinsic is a convenient \texttt{Fortran90} trick for turning the rank-one array with one element returned by [[maxloc]] into its value. It has no semantic significance.} <>= abs_evec = abs (evecs(:,iv)) i(1) = sum (maxloc (abs_evec)) abs_evec(i(1)) = -1.0 i(2) = sum (maxloc (abs_evec)) @ %def abs_evec i @ The following is cute, but unfortunately broken, since it fails for dgenerate eigenvalues: <>= abs_evec = abs (evecs(:,iv)) i(1) = sum (maxloc (abs_evec)) i(2) = sum (maxloc (abs_evec, mask = abs_evec < abs_evec(i(1)))) @ %def abs_evec i @ <>= print *, iv, evals(iv), " => ", evecs(:,iv) print *, i(1), abs_evec(i(1)), ", ", i(2), abs_evec(i(2)) print *, i(1), evecs(i(1),iv), ", ", i(2), evecs(i(2),iv) -@ +@ <>= cos_theta = evecs(i(1),iv) sin_theta = evecs(i(2),iv) norm = 1.0 / sqrt (cos_theta**2 + sin_theta**2) cos_theta = cos_theta * norm sin_theta = sin_theta * norm @ %def cos_theta sin_theta norm @ \begin{equation} \hat R(\theta;i,j) = \begin{pmatrix} 1 & & & & & & \\ & \ddots & & & & & \\ & & \cos\theta & \cdots & -\sin\theta & & \\ & & \vdots & 1 & \vdots & & \\ & & \sin\theta & \cdots & \cos\theta & & \\ & & & & & \ddots & \\ & & & & & & 1 \end{pmatrix} \end{equation} <>= call unit (r) r(i(1),i) = (/ cos_theta, - sin_theta /) r(i(2),i) = (/ sin_theta, cos_theta /) @ %def r @ <>= subroutine select_rotation_axis (cov, r, pancake, cigar) real(kind=default), dimension(:,:), intent(in) :: cov real(kind=default), dimension(:,:), intent(out) :: r integer, intent(in), optional :: pancake, cigar integer :: num_pancake, num_cigar logical :: like_pancake real(kind=default), dimension(size(cov,dim=1),size(cov,dim=2)) :: evecs real(kind=default), dimension(size(cov,dim=1)) :: evals, abs_evec integer :: iv integer, dimension(2) :: i real(kind=default) :: cos_theta, sin_theta, norm <> call diagonalize_real_symmetric (cov, evals, evecs) <> <> <> <> end subroutine select_rotation_axis @ %def select_rotation_axis -@ +@ <>= if (present (pancake)) then num_pancake = pancake else num_pancake = -1 endif if (present (cigar)) then num_cigar = cigar else num_cigar = -1 endif @ Here's a less efficient version that can be easily generalized to more than two dimension, however: <>= subroutine select_subspace_explicit (cov, r, subspace) real(kind=default), dimension(:,:), intent(in) :: cov real(kind=default), dimension(:,:), intent(out) :: r integer, dimension(:), intent(in) :: subspace real(kind=default), dimension(size(subspace)) :: eval_sub real(kind=default), dimension(size(subspace),size(subspace)) :: & cov_sub, evec_sub cov_sub = cov(subspace,subspace) call diagonalize_real_symmetric (cov_sub, eval_sub, evec_sub) call unit (r) r(subspace,subspace) = evec_sub end subroutine select_subspace_explicit @ %def select_subspace_explicit -@ +@ <>= subroutine select_subspace_guess (cov, r, ndim, pancake, cigar) real(kind=default), dimension(:,:), intent(in) :: cov real(kind=default), dimension(:,:), intent(out) :: r integer, intent(in) :: ndim integer, intent(in), optional :: pancake, cigar integer :: num_pancake, num_cigar logical :: like_pancake real(kind=default), dimension(size(cov,dim=1),size(cov,dim=2)) :: evecs real(kind=default), dimension(size(cov,dim=1)) :: evals, abs_evec integer :: iv, i integer, dimension(ndim) :: subspace <> call diagonalize_real_symmetric (cov, evals, evecs) <> <> call select_subspace_explicit (cov, r, subspace) end subroutine select_subspace_guess @ %def select_subspace_guess -@ +@ <>= abs_evec = abs (evecs(:,iv)) subspace(1) = sum (maxloc (abs_evec)) do i = 2, ndim abs_evec(subspace(i-1)) = -1.0 subspace(i) = sum (maxloc (abs_evec)) end do -@ +@ <>= interface select_rotation_subspace module procedure select_subspace_explicit, select_subspace_guess end interface @ %def select_rotation_subspace @ <>= private :: select_subspace_explicit private :: select_subspace_guess @ %def select_subspace_explicit @ %def select_subspace_guess @ <>= public :: vamp_print_covariance @ %def vamp_print_covariance -@ +@ <>= subroutine vamp_print_covariance (cov) real(kind=default), dimension(:,:), intent(in) :: cov real(kind=default), dimension(size(cov,dim=1)) :: & evals, abs_evals, tmp real(kind=default), dimension(size(cov,dim=1),size(cov,dim=2)) :: & evecs, abs_evecs integer, dimension(size(cov,dim=1)) :: idx integer :: i, i_max, j i_max = size (evals) call diagonalize_real_symmetric (cov, evals, evecs) call sort (evals, evecs) abs_evals = abs (evals) abs_evecs = abs (evecs) print "(1X,A78)", repeat ("-", 78) print "(1X,A)", "Eigenvalues and eigenvectors:" print "(1X,A78)", repeat ("-", 78) do i = 1, i_max print "(1X,I2,A1,1X,E11.4,1X,A1,10(10(1X,F5.2)/,18X))", & i, ":", evals(i), "|", evecs(:,i) end do print "(1X,A78)", repeat ("-", 78) print "(1X,A)", "Approximate subspaces:" print "(1X,A78)", repeat ("-", 78) do i = 1, i_max idx = (/ (j, j=1,i_max) /) tmp = abs_evecs(:,i) call sort (tmp, idx, reverse = .true.) print "(1X,I2,A1,1X,E11.4,1X,A1,10(1X,I5))", & i, ":", evals(i), "|", idx(1:min(10,size(idx))) print "(17X,A1,10(1X,F5.2))", & "|", evecs(idx(1:min(10,size(idx))),i) end do print "(1X,A78)", repeat ("-", 78) end subroutine vamp_print_covariance @ %def vamp_print_covariance @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Condensing Eigenvalues} In order to decide whether we have a ``pancake'' or a ``cigar'', we have to classify the eiegenvalues of the covariance matrix. We do this by condensing the~$n_{\text{dim}}$ eigenvalues into ~$n_{\text{cl}}\ll n_{\text{dim}}$ clusters. <>= ! private :: condense public :: condense @ The rough description is as follows: in each step, combine the nearst neighbours (according to an approbriate metric) to form a smaller set. This is an extremely simplified, discretized modeling of molecules condensing under the influence of some potential. \begin{dubious} If there's not a clean separation, this algorithm is certainly chaotic and we need to apply some form of damping! \end{dubious} @ <>= cl_pos = x cl_num = size (cl_pos) cl = spread ((/ (i, i=1,cl_num) /), dim = 2, ncopies = 2) @ %def cl_pos cl_num cl @ It appears that the logarithmic metric \begin{subequations} \begin{align} d_0 (x,y) &= \left|\log\left(\frac{x}{y}\right)\right| \\ \intertext{performs better than the linear metric} d_1 (x,y) &= |x-y| \\ \intertext{% since the latter won't separate very small eiegenvalues from the - bulk. Another option is} + bulk. Another option is} d_\alpha (x,y) &= |x^\alpha-y^\alpha| \end{align} \end{subequations} with~$\alpha\not=1$, in particular~$\alpha\approx-1$. I haven't studied it yet, though. \begin{dubious} \index{more empirical studies helpful} but I should perform more empirical studies to determine whether the logarithmic or the linear metric is more appropriate in realistic cases. \end{dubious} <>= if (linear_metric) then gap = sum (minloc (cl_pos(2:cl_num) - cl_pos(1:cl_num-1))) else gap = sum (minloc (cl_pos(2:cl_num) / cl_pos(1:cl_num-1))) end if wgt0 = cl(gap,2) - cl(gap,1) + 1 wgt1 = cl(gap+1,2) - cl(gap+1,1) + 1 cl_pos(gap) = (wgt0 * cl_pos(gap) + wgt1 * cl_pos(gap+1)) / (wgt0 + wgt1) cl(gap,2) = cl(gap+1,2) @ %def gap wgt0 wgt1 cl_pos cl -@ +@ <>= cl_pos(gap+1:cl_num-1) = cl_pos(gap+2:cl_num) cl(gap+1:cl_num-1,:) = cl(gap+2:cl_num,:) @ %def cl_pos cl @ <>= subroutine condense (x, cluster_pos, clusters, linear) real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:), intent(out) :: cluster_pos integer, dimension(:,:), intent(out) :: clusters logical, intent(in), optional :: linear logical :: linear_metric real(kind=default), dimension(size(x)) :: cl_pos real(kind=default) :: wgt0, wgt1 integer :: cl_num integer, dimension(size(x),2) :: cl integer :: i, gap linear_metric = .false. if (present (linear)) then linear_metric = linear end if <> do cl_num = size (cl_pos), size (cluster_pos) + 1, -1 <> print *, cl_num, ": action = ", condense_action (x, cl) end do cluster_pos = cl_pos(1:cl_num) clusters = cl(1:cl_num,:) end subroutine condense @ %def condense @ <>= ! private :: condense_action public :: condense_action @ \begin{equation} S = \sum_{c\in\text{clusters}} \mathop{\textrm{var}}\nolimits^{\frac{\alpha}{2}}(c) \end{equation} <>= function condense_action (positions, clusters) result (s) real(kind=default), dimension(:), intent(in) :: positions integer, dimension(:,:), intent(in) :: clusters real(kind=default) :: s integer :: i integer, parameter :: POWER = 2 s = 0 do i = 1, size (clusters, dim = 1) s = s + standard_deviation (positions(clusters(i,1) & :clusters(i,2))) ** POWER end do end function condense_action -@ +@ <<[[ctest.f90]]>>= program ctest use kinds use utils use vamp_stat use tao_random_numbers use vamp implicit none integer, parameter :: N = 16, NC = 2 real(kind=default), dimension(N) :: eval real(kind=default), dimension(NC) :: cluster_pos integer, dimension(NC,2) :: clusters integer :: i call tao_random_number (eval) call sort (eval) print *, eval eval(1:N/2) = 0.95*eval(1:N/2) eval(N/2+1:N) = 1.0 - 0.95*(1.0 - eval(N/2+1:N)) print *, eval call condense (eval, cluster_pos, clusters, linear=.true.) do i = 1, NC print "(I2,A,F5.2,A,I2,A,I2,A,A,F5.2,A,F5.2,A,32F5.2)", & i, ": ", cluster_pos(i), & " [", clusters(i,1), "-", clusters(i,2), "]", & " [", eval(clusters(i,1)), " - ", eval(clusters(i,2)), "]", & eval(clusters(i,1)+1:clusters(i,2)) & - eval(clusters(i,1):clusters(i,2)-1) print *, average (eval(clusters(i,1):clusters(i,2))), "+/-", & standard_deviation (eval(clusters(i,1):clusters(i,2))) end do end program ctest @ %def ctest @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Event Generation} Automagically adaptive tools are not always appropriate for unweighted event generation, but we can give it a try. <>= public :: vamp_next_event -@ +@ <>= interface vamp_next_event module procedure vamp_next_event_single, vamp_next_event_multi end interface -@ +@ <>= private :: vamp_next_event_single, vamp_next_event_multi @ Both event generation routines operate in two modes, depending on whether the optional argument [[weight]] is present. <>= subroutine vamp_next_event_single & (x, rng, g, func, data, & weight, channel, weights, grids, exc) real(kind=default), dimension(:), intent(out) :: x type(tao_random_state), intent(inout) :: rng type(vamp_grid), intent(inout) :: g real(kind=default), intent(out), optional :: weight class(vamp_data_t), intent(in) :: data integer, intent(in), optional :: channel real(kind=default), dimension(:), intent(in), optional :: weights type(vamp_grid), dimension(:), intent(in), optional :: grids type(exception), intent(inout), optional :: exc <> character(len=*), parameter :: FN = "vamp_next_event_single" real(kind=default), dimension(size(g%div)):: wgts real(kind=default), dimension(size(g%div)):: r integer, dimension(size(g%div)):: ia real(kind=default) :: f, wgt real(kind=default) :: r0 rejection: do <> if (present (weight)) then <> else <> end if end do rejection end subroutine vamp_next_event_single @ %def vamp_next_event_single -@ +@ <>= call tao_random_number (rng, r) call inject_division_short (g%div, real(r, kind=default), x, ia, wgts) wgt = g%jacobi * product (wgts) wgt = g%calls * wgt !: the calling procedure will divide by \#calls if (associated (g%map)) then x = matmul (g%map, x) end if <<[[f = wgt * func (x, weights, channel)]], iff [[x]] inside [[true_domain]]>> ! call record_efficiency (g%div, ia, f/g%f_max) -@ +@ <>= weight = f exit rejection @ <>= -if (f > g%f_max) then +if (abs(f) > g%f_max) then g%f_max = f call raise_exception (exc, EXC_WARN, FN, "weight > 1") exit rejection end if call tao_random_number (rng, r0) -if (r0 * g%f_max <= f) then +if (r0 * g%f_max <= abs(f)) then exit rejection end if @ We know that [[g%weights]] are normalized: [[sum (g%weights) == 1.0]]. The basic formula for multi channel sampling is \begin{equation} f(x) = \sum_i \alpha_i g_i(x) w(x) \end{equation} with~$w(x)=f(x)/g(x)=f(x)/\sum_i\alpha_ig_i(x)$ and~$\sum_i\alpha_i=1$. The non-trivial poblem is that the adaptive grid is diferent in each channel, so we can't just reject on~$w(x)$. <>= subroutine vamp_next_event_multi & (x, rng, g, func, data, phi, weight, excess, positive, exc) real(kind=default), dimension(:), intent(out) :: x type(tao_random_state), intent(inout) :: rng type(vamp_grids), intent(inout) :: g class(vamp_data_t), intent(in) :: data real(kind=default), intent(out), optional :: weight real(kind=default), intent(out), optional :: excess logical, intent(out), optional :: positive type(exception), intent(inout), optional :: exc <> <> character(len=*), parameter :: FN = "vamp_next_event_multi" real(kind=default), dimension(size(x)) :: xi real(kind=default) :: r, wgt real(kind=default), dimension(size(g%weights)) :: weights integer :: channel <<[[weights]]: $\alpha_i\to w_{\max,i}\alpha_i$>> rejection: do <>= call tao_random_number (rng, r) select_channel: do channel = 1, size (g%weights) r = r - weights(channel) if (r <= 0.0) then exit select_channel end if end do select_channel channel = min (channel, size (g%weights)) !: for $r=1$ and rounding errors -@ +@ <>= weight = wgt * g%weights(channel) / weights(channel) exit rejection @ <>= if (abs (wgt) > g%grids(channel)%f_max) then if (present(excess)) then excess = abs (wgt) / g%grids(channel)%f_max - 1 else call raise_exception (exc, EXC_WARN, FN, "weight > 1") ! print *, "weight > 1 (", wgt/g%grids(channel)%f_max, & ! & ") in channel ", channel end if ! exit rejection else if (present(excess)) excess = 0 end if call tao_random_number (rng, r) if (r * g%grids(channel)%f_max <= abs (wgt)) then if (present (positive)) positive = wgt >= 0 exit rejection end if @ <>= if (wgt > g%grids(channel)%f_max) then g%grids(channel)%f_max = wgt <<[[weights]]: $\alpha_i\to w_{\max,i}\alpha_i$>> call raise_exception (exc, EXC_WARN, FN, "weight > 1") exit rejection end if call tao_random_number (rng, r) if (r * g%grids(channel)%f_max <= wgt) then exit rejection end if @ Using [[vamp_sample_grid (g, ...)]] to warm up the grid~[[g]] has a somewhat subtle problem: the minimum and maximum weights [[g%f_min]] and [[g%f_max]] refer to the grid \emph{before} the final refinement. One could require an additional [[vamp_sample_grid0 (g, ...)]], but users are likely to forget such technical details. A better solution is a wrapper [[vamp_warmup_grid (g, ...)]] that drops the final refinement transparently. <>= public :: vamp_warmup_grid, vamp_warmup_grids @ <>= subroutine vamp_warmup_grid & (rng, g, func, data, iterations, exc, history) type(tao_random_state), intent(inout) :: rng type(vamp_grid), intent(inout) :: g class(vamp_data_t), intent(in) :: data integer, intent(in) :: iterations type(exception), intent(inout), optional :: exc type(vamp_history), dimension(:), intent(inout), optional :: history <> call vamp_sample_grid & (rng, g, func, data, & iterations - 1, exc = exc, history = history) call vamp_sample_grid0 (rng, g, func, data, exc = exc) end subroutine vamp_warmup_grid @ %def vamp_warmup_grid @ \begin{dubious} \texttt{WHERE ... END WHERE} alert! \end{dubious} <>= subroutine vamp_warmup_grids & (rng, g, func, data, iterations, history, histories, exc) type(tao_random_state), intent(inout) :: rng type(vamp_grids), intent(inout) :: g class(vamp_data_t), intent(in) :: data integer, intent(in) :: iterations type(vamp_history), dimension(:), intent(inout), optional :: history type(vamp_history), dimension(:,:), intent(inout), optional :: histories type(exception), intent(inout), optional :: exc <> integer :: ch logical, dimension(size(g%grids)) :: active real(kind=default), dimension(size(g%grids)) :: weights active = (g%num_calls >= 2) where (active) weights = g%num_calls elsewhere weights = 0.0 end where weights = weights / sum (weights) call vamp_sample_grids (rng, g, func, data, iterations - 1, & exc = exc, history = history, histories = histories) do ch = 1, size (g%grids) if (g%grids(ch)%num_calls >= 2) then call vamp_sample_grid0 & (rng, g%grids(ch), func, data, & ch, weights, g%grids, exc = exc) end if end do end subroutine vamp_warmup_grids @ %def vamp_warmup_grids @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Convenience Routines} <>= public :: vamp_integrate private :: vamp_integrate_grid, vamp_integrate_region -@ +@ <>= interface vamp_integrate module procedure vamp_integrate_grid, vamp_integrate_region end interface @ <>= subroutine vamp_integrate_grid & (rng, g, func, data, calls, integral, std_dev, avg_chi2, num_div, & stratified, quadrupole, accuracy, exc, history) type(tao_random_state), intent(inout) :: rng type(vamp_grid), intent(inout) :: g class(vamp_data_t), intent(in) :: data integer, dimension(:,:), intent(in) :: calls real(kind=default), intent(out), optional :: integral, std_dev, avg_chi2 integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole real(kind=default), intent(in), optional :: accuracy type(exception), intent(inout), optional :: exc type(vamp_history), dimension(:), intent(inout), optional :: history <> character(len=*), parameter :: FN = "vamp_integrate_grid" integer :: step, last_step, it last_step = size (calls, dim = 2) it = 1 do step = 1, last_step - 1 call vamp_discard_integral (g, calls(2,step), num_div, & stratified, quadrupole, exc = exc) call vamp_sample_grid (rng, g, func, data, calls(1,step), & exc = exc, history = history(it:)) <> it = it + calls(1,step) end do call vamp_discard_integral (g, calls(2,last_step), exc = exc) call vamp_sample_grid (rng, g, func, data, calls(1,last_step), & integral, std_dev, avg_chi2, accuracy, exc = exc, & history = history(it:)) end subroutine vamp_integrate_grid @ %def vamp_integrate_grid @ <>= subroutine vamp_integrate_region & (rng, region, func, data, calls, & integral, std_dev, avg_chi2, num_div, & stratified, quadrupole, accuracy, map, covariance, exc, history) type(tao_random_state), intent(inout) :: rng real(kind=default), dimension(:,:), intent(in) :: region class(vamp_data_t), intent(in) :: data integer, dimension(:,:), intent(in) :: calls real(kind=default), intent(out), optional :: integral, std_dev, avg_chi2 integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole real(kind=default), intent(in), optional :: accuracy real(kind=default), dimension(:,:), intent(in), optional :: map real(kind=default), dimension(:,:), intent(out), optional :: covariance type(exception), intent(inout), optional :: exc type(vamp_history), dimension(:), intent(inout), optional :: history <> character(len=*), parameter :: FN = "vamp_integrate_region" type(vamp_grid) :: g call vamp_create_grid & (g, region, calls(2,1), num_div, & stratified, quadrupole, present (covariance), map, exc) call vamp_integrate_grid & (rng, g, func, data, calls, & integral, std_dev, avg_chi2, num_div, & accuracy = accuracy, exc = exc, history = history) if (present (covariance)) then covariance = vamp_get_covariance (g) end if call vamp_delete_grid (g) end subroutine vamp_integrate_region @ %def vamp_integrate_region -@ +@ <>= public :: vamp_integratex private :: vamp_integratex_region -@ +@ <>= interface vamp_integratex module procedure vamp_integratex_region end interface @ <>= subroutine vamp_integratex_region & (rng, region, func, data, calls, integral, std_dev, avg_chi2, & num_div, stratified, quadrupole, accuracy, pancake, cigar, & exc, history) type(tao_random_state), intent(inout) :: rng real(kind=default), dimension(:,:), intent(in) :: region class(vamp_data_t), intent(in) :: data integer, dimension(:,:,:), intent(in) :: calls real(kind=default), intent(out), optional :: integral, std_dev, avg_chi2 integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole real(kind=default), intent(in), optional :: accuracy integer, intent(in), optional :: pancake, cigar type(exception), intent(inout), optional :: exc type(vamp_history), dimension(:), intent(inout), optional :: history <> real(kind=default), dimension(size(region,dim=2)) :: eval real(kind=default), dimension(size(region,dim=2),size(region,dim=2)) :: evec type(vamp_grid) :: g integer :: step, last_step, it it = 1 call vamp_create_grid & (g, region, calls(2,1,1), num_div, & stratified, quadrupole, covariance = .true., exc = exc) call vamp_integrate_grid & (rng, g, func, data, calls(:,:,1), num_div = num_div, & exc = exc, history = history(it:)) <> it = it + sum (calls(1,:,1)) last_step = size (calls, dim = 3) do step = 2, last_step - 1 call diagonalize_real_symmetric (vamp_get_covariance(g), eval, evec) call sort (eval, evec) call select_rotation_axis (vamp_get_covariance(g), evec, pancake, cigar) call vamp_delete_grid (g) call vamp_create_grid & (g, region, calls(2,1,step), num_div, stratified, quadrupole, & covariance = .true., map = evec, exc = exc) call vamp_integrate_grid & (rng, g, func, data, calls(:,:,step), num_div = num_div, & exc = exc, history = history(it:)) <> it = it + sum (calls(1,:,step)) end do call diagonalize_real_symmetric (vamp_get_covariance(g), eval, evec) call sort (eval, evec) call select_rotation_axis (vamp_get_covariance(g), evec, pancake, cigar) call vamp_delete_grid (g) call vamp_create_grid & (g, region, calls(2,1,last_step), num_div, stratified, quadrupole, & covariance = .true., map = evec, exc = exc) call vamp_integrate_grid & (rng, g, func, data, calls(:,:,last_step), & integral, std_dev, avg_chi2, & num_div = num_div, exc = exc, history = history(it:)) call vamp_delete_grid (g) end subroutine vamp_integratex_region @ %def vamp_integratex_region @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{I/O} <>= public :: vamp_write_grid private :: write_grid_unit, write_grid_name public :: vamp_read_grid private :: read_grid_unit, read_grid_name public :: vamp_write_grids private :: write_grids_unit, write_grids_name public :: vamp_read_grids private :: read_grids_unit, read_grids_name -@ +@ <>= public :: vamp_read_grids_raw private :: read_grids_raw_unit, read_grids_raw_name public :: vamp_read_grid_raw private :: read_grid_raw_unit, read_grid_raw_name public :: vamp_write_grids_raw private :: write_grids_raw_unit, write_grids_raw_name public :: vamp_write_grid_raw private :: write_grid_raw_unit, write_grid_raw_name @ <>= interface vamp_write_grid module procedure write_grid_unit, write_grid_name end interface interface vamp_read_grid module procedure read_grid_unit, read_grid_name end interface interface vamp_write_grids module procedure write_grids_unit, write_grids_name end interface interface vamp_read_grids module procedure read_grids_unit, read_grids_name end interface @ %def vamp_write_grids @ %def vamp_read_grids @ %def vamp_write_grid @ %def vamp_read_grid @ <>= interface vamp_write_grid_raw module procedure write_grid_raw_unit, write_grid_raw_name end interface interface vamp_read_grid_raw module procedure read_grid_raw_unit, read_grid_raw_name end interface interface vamp_write_grids_raw module procedure write_grids_raw_unit, write_grids_raw_name end interface interface vamp_read_grids_raw module procedure read_grids_raw_unit, read_grids_raw_name end interface @ %def vamp_write_grids_raw @ %def vamp_read_grids_raw @ %def vamp_write_grid_raw @ %def vamp_read_grid_raw @ <>= subroutine write_grid_unit (g, unit, write_integrals) type(vamp_grid), intent(in) :: g integer, intent(in) :: unit logical, intent(in), optional :: write_integrals integer :: i, j write (unit = unit, fmt = descr_fmt) "begin type(vamp_grid) :: g" write (unit = unit, fmt = integer_fmt) "size (g%div) = ", size (g%div) write (unit = unit, fmt = integer_fmt) "num_calls = ", g%num_calls write (unit = unit, fmt = integer_fmt) "calls_per_cell = ", g%calls_per_cell write (unit = unit, fmt = logical_fmt) "stratified = ", g%stratified write (unit = unit, fmt = logical_fmt) "all_stratified = ", g%all_stratified write (unit = unit, fmt = logical_fmt) "quadrupole = ", g%quadrupole write (unit = unit, fmt = double_fmt) "mu(1) = ", g%mu(1) write (unit = unit, fmt = double_fmt) "mu(2) = ", g%mu(2) write (unit = unit, fmt = double_fmt) "mu_plus(1) = ", g%mu_plus(1) write (unit = unit, fmt = double_fmt) "mu_plus(2) = ", g%mu_plus(2) write (unit = unit, fmt = double_fmt) "mu_minus(1) = ", g%mu_minus(1) write (unit = unit, fmt = double_fmt) "mu_minus(2) = ", g%mu_minus(2) write (unit = unit, fmt = double_fmt) "sum_integral = ", g%sum_integral write (unit = unit, fmt = double_fmt) "sum_weights = ", g%sum_weights write (unit = unit, fmt = double_fmt) "sum_chi2 = ", g%sum_chi2 write (unit = unit, fmt = double_fmt) "calls = ", g%calls write (unit = unit, fmt = double_fmt) "dv2g = ", g%dv2g write (unit = unit, fmt = double_fmt) "jacobi = ", g%jacobi write (unit = unit, fmt = double_fmt) "f_min = ", g%f_min write (unit = unit, fmt = double_fmt) "f_max = ", g%f_max write (unit = unit, fmt = double_fmt) "mu_gi = ", g%mu_gi write (unit = unit, fmt = double_fmt) "sum_mu_gi = ", g%sum_mu_gi write (unit = unit, fmt = descr_fmt) "begin g%num_div" do i = 1, size (g%div) write (unit = unit, fmt = integer_array_fmt) i, g%num_div(i) end do write (unit = unit, fmt = descr_fmt) "end g%num_div" write (unit = unit, fmt = descr_fmt) "begin g%div" do i = 1, size (g%div) call write_division (g%div(i), unit, write_integrals) end do write (unit = unit, fmt = descr_fmt) "end g%div" if (associated (g%map)) then write (unit = unit, fmt = descr_fmt) "begin g%map" do i = 1, size (g%div) do j = 1, size (g%div) write (unit = unit, fmt = double_array2_fmt) i, j, g%map(i,j) end do end do write (unit = unit, fmt = descr_fmt) "end g%map" else write (unit = unit, fmt = descr_fmt) "empty g%map" end if if (associated (g%mu_x)) then write (unit = unit, fmt = descr_fmt) "begin g%mu_x" do i = 1, size (g%div) write (unit = unit, fmt = double_array_fmt) i, g%mu_x(i) write (unit = unit, fmt = double_array_fmt) i, g%sum_mu_x(i) do j = 1, size (g%div) write (unit = unit, fmt = double_array2_fmt) i, j, g%mu_xx(i,j) write (unit = unit, fmt = double_array2_fmt) i, j, g%sum_mu_xx(i,j) end do end do write (unit = unit, fmt = descr_fmt) "end g%mu_x" else write (unit = unit, fmt = descr_fmt) "empty g%mu_x" end if write (unit = unit, fmt = descr_fmt) "end type(vamp_grid)" end subroutine write_grid_unit @ %def write_grid_unit @ <>= character(len=*), parameter, private :: & descr_fmt = "(1x,a)", & integer_fmt = "(1x,a17,1x,i15)", & integer_array_fmt = "(1x,i17,1x,i15)", & logical_fmt = "(1x,a17,1x,l1)", & double_fmt = "(1x,a17,1x,e30.22e4)", & double_array_fmt = "(1x,i17,1x,e30.22e4)", & double_array2_fmt = "(2(1x,i8),1x,e30.22e4)" @ %def descr_fmt integer_fmt integer_array_fmt logical_fmt @ %def double_fmt double_array_fmt double_array2_fmt @ <>= subroutine read_grid_unit (g, unit, read_integrals) type(vamp_grid), intent(inout) :: g integer, intent(in) :: unit logical, intent(in), optional :: read_integrals character(len=*), parameter :: FN = "vamp_read_grid" character(len=80) :: chdum integer :: ndim, i, j, idum, jdum read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = integer_fmt) chdum, ndim <> call create_array_pointer (g%num_div, ndim) read (unit = unit, fmt = integer_fmt) chdum, g%num_calls read (unit = unit, fmt = integer_fmt) chdum, g%calls_per_cell read (unit = unit, fmt = logical_fmt) chdum, g%stratified read (unit = unit, fmt = logical_fmt) chdum, g%all_stratified read (unit = unit, fmt = logical_fmt) chdum, g%quadrupole read (unit = unit, fmt = double_fmt) chdum, g%mu(1) read (unit = unit, fmt = double_fmt) chdum, g%mu(2) read (unit = unit, fmt = double_fmt) chdum, g%mu_plus(1) read (unit = unit, fmt = double_fmt) chdum, g%mu_plus(2) read (unit = unit, fmt = double_fmt) chdum, g%mu_minus(1) read (unit = unit, fmt = double_fmt) chdum, g%mu_minus(2) read (unit = unit, fmt = double_fmt) chdum, g%sum_integral read (unit = unit, fmt = double_fmt) chdum, g%sum_weights read (unit = unit, fmt = double_fmt) chdum, g%sum_chi2 read (unit = unit, fmt = double_fmt) chdum, g%calls read (unit = unit, fmt = double_fmt) chdum, g%dv2g read (unit = unit, fmt = double_fmt) chdum, g%jacobi read (unit = unit, fmt = double_fmt) chdum, g%f_min read (unit = unit, fmt = double_fmt) chdum, g%f_max read (unit = unit, fmt = double_fmt) chdum, g%mu_gi read (unit = unit, fmt = double_fmt) chdum, g%sum_mu_gi read (unit = unit, fmt = descr_fmt) chdum do i = 1, size (g%div) read (unit = unit, fmt = integer_array_fmt) idum, g%num_div(i) end do read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = descr_fmt) chdum do i = 1, size (g%div) call read_division (g%div(i), unit, read_integrals) end do read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = descr_fmt) chdum if (chdum == "begin g%map") then call create_array_pointer (g%map, (/ ndim, ndim /)) do i = 1, size (g%div) do j = 1, size (g%div) read (unit = unit, fmt = double_array2_fmt) idum, jdum, g%map(i,j) end do end do read (unit = unit, fmt = descr_fmt) chdum else <> end if read (unit = unit, fmt = descr_fmt) chdum if (chdum == "begin g%mu_x") then call create_array_pointer (g%mu_x, ndim ) call create_array_pointer (g%sum_mu_x, ndim) call create_array_pointer (g%mu_xx, (/ ndim, ndim /)) call create_array_pointer (g%sum_mu_xx, (/ ndim, ndim /)) do i = 1, size (g%div) read (unit = unit, fmt = double_array_fmt) idum, jdum, g%mu_x(i) read (unit = unit, fmt = double_array_fmt) idum, jdum, g%sum_mu_x(i) do j = 1, size (g%div) read (unit = unit, fmt = double_array2_fmt) & idum, jdum, g%mu_xx(i,j) read (unit = unit, fmt = double_array2_fmt) & idum, jdum, g%sum_mu_xx(i,j) end do end do read (unit = unit, fmt = descr_fmt) chdum else <> end if read (unit = unit, fmt = descr_fmt) chdum end subroutine read_grid_unit @ %def read_grid_unit -@ +@ <>= if (associated (g%div)) then if (size (g%div) /= ndim) then call delete_division (g%div) deallocate (g%div) allocate (g%div(ndim)) call create_empty_division (g%div) end if else allocate (g%div(ndim)) call create_empty_division (g%div) end if @ <>= if (associated (g%map)) then deallocate (g%map) end if @ <>= if (associated (g%mu_x)) then deallocate (g%mu_x) end if if (associated (g%mu_xx)) then deallocate (g%mu_xx) end if if (associated (g%sum_mu_x)) then deallocate (g%sum_mu_x) end if if (associated (g%sum_mu_xx)) then deallocate (g%sum_mu_xx) end if -@ +@ <>= subroutine write_grid_name (g, name, write_integrals) type(vamp_grid), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: write_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "write", status = "replace", file = name) call write_grid_unit (g, unit, write_integrals) close (unit = unit) end subroutine write_grid_name @ %def write_grid_name -@ +@ <>= subroutine read_grid_name (g, name, read_integrals) type(vamp_grid), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: read_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "read", status = "old", file = name) call read_grid_unit (g, unit, read_integrals) close (unit = unit) end subroutine read_grid_name @ %def read_grid_name @ <>= subroutine write_grids_unit (g, unit, write_integrals) type(vamp_grids), intent(in) :: g integer, intent(in) :: unit logical, intent(in), optional :: write_integrals integer :: i write (unit = unit, fmt = descr_fmt) "begin type(vamp_grids) :: g" write (unit = unit, fmt = integer_fmt) "size (g%grids) = ", size (g%grids) write (unit = unit, fmt = double_fmt) "sum_integral = ", g%sum_integral write (unit = unit, fmt = double_fmt) "sum_weights = ", g%sum_weights write (unit = unit, fmt = double_fmt) "sum_chi2 = ", g%sum_chi2 write (unit = unit, fmt = descr_fmt) "begin g%weights" do i = 1, size (g%grids) write (unit = unit, fmt = double_array_fmt) i, g%weights(i) end do write (unit = unit, fmt = descr_fmt) "end g%weights" write (unit = unit, fmt = descr_fmt) "begin g%num_calls" do i = 1, size (g%grids) write (unit = unit, fmt = integer_array_fmt) i, g%num_calls(i) end do write (unit = unit, fmt = descr_fmt) "end g%num_calls" write (unit = unit, fmt = descr_fmt) "begin g%grids" do i = 1, size (g%grids) call write_grid_unit (g%grids(i), unit, write_integrals) end do write (unit = unit, fmt = descr_fmt) "end g%grids" write (unit = unit, fmt = descr_fmt) "end type(vamp_grids)" end subroutine write_grids_unit @ %def write_grids_unit @ <>= subroutine read_grids_unit (g, unit, read_integrals) type(vamp_grids), intent(inout) :: g integer, intent(in) :: unit logical, intent(in), optional :: read_integrals character(len=*), parameter :: FN = "vamp_read_grids" character(len=80) :: chdum integer :: i, nch, idum read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = integer_fmt) chdum, nch if (associated (g%grids)) then if (size (g%grids) /= nch) then call vamp_delete_grid (g%grids) deallocate (g%grids, g%weights, g%num_calls) allocate (g%grids(nch), g%weights(nch), g%num_calls(nch)) call vamp_create_empty_grid (g%grids) end if else allocate (g%grids(nch), g%weights(nch), g%num_calls(nch)) call vamp_create_empty_grid (g%grids) end if read (unit = unit, fmt = double_fmt) chdum, g%sum_integral read (unit = unit, fmt = double_fmt) chdum, g%sum_weights read (unit = unit, fmt = double_fmt) chdum, g%sum_chi2 read (unit = unit, fmt = descr_fmt) chdum do i = 1, nch read (unit = unit, fmt = double_array_fmt) idum, g%weights(i) end do read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = descr_fmt) chdum do i = 1, nch read (unit = unit, fmt = integer_array_fmt) idum, g%num_calls(i) end do read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = descr_fmt) chdum do i = 1, nch call read_grid_unit (g%grids(i), unit, read_integrals) end do read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = descr_fmt) chdum end subroutine read_grids_unit @ %def read_grids_unit -@ +@ <>= subroutine write_grids_name (g, name, write_integrals) type(vamp_grids), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: write_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "write", status = "replace", file = name) call write_grids_unit (g, unit, write_integrals) close (unit = unit) end subroutine write_grids_name @ %def write_grids_name -@ +@ <>= subroutine read_grids_name (g, name, read_integrals) type(vamp_grids), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: read_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "read", status = "old", file = name) call read_grids_unit (g, unit, read_integrals) close (unit = unit) end subroutine read_grids_name @ %def read_grids_name @ <>= subroutine write_grid_raw_unit (g, unit, write_integrals) type(vamp_grid), intent(in) :: g integer, intent(in) :: unit logical, intent(in), optional :: write_integrals integer :: i, j write (unit = unit) MAGIC_GRID_BEGIN write (unit = unit) size (g%div) write (unit = unit) g%num_calls write (unit = unit) g%calls_per_cell write (unit = unit) g%stratified write (unit = unit) g%all_stratified write (unit = unit) g%quadrupole write (unit = unit) g%mu(1) write (unit = unit) g%mu(2) write (unit = unit) g%mu_plus(1) write (unit = unit) g%mu_plus(2) write (unit = unit) g%mu_minus(1) write (unit = unit) g%mu_minus(2) write (unit = unit) g%sum_integral write (unit = unit) g%sum_weights write (unit = unit) g%sum_chi2 write (unit = unit) g%calls write (unit = unit) g%dv2g write (unit = unit) g%jacobi write (unit = unit) g%f_min write (unit = unit) g%f_max write (unit = unit) g%mu_gi write (unit = unit) g%sum_mu_gi do i = 1, size (g%div) write (unit = unit) g%num_div(i) end do do i = 1, size (g%div) call write_division_raw (g%div(i), unit, write_integrals) end do if (associated (g%map)) then write (unit = unit) MAGIC_GRID_MAP do i = 1, size (g%div) do j = 1, size (g%div) write (unit = unit) g%map(i,j) end do end do else write (unit = unit) MAGIC_GRID_EMPTY end if if (associated (g%mu_x)) then write (unit = unit) MAGIC_GRID_MU_X do i = 1, size (g%div) write (unit = unit) g%mu_x(i) write (unit = unit) g%sum_mu_x(i) do j = 1, size (g%div) write (unit = unit) g%mu_xx(i,j) write (unit = unit) g%sum_mu_xx(i,j) end do end do else write (unit = unit) MAGIC_GRID_EMPTY end if write (unit = unit) MAGIC_GRID_END end subroutine write_grid_raw_unit @ %def write_grid_raw_unit @ <>= integer, parameter, private :: MAGIC_GRID = 22222222 integer, parameter, private :: MAGIC_GRID_BEGIN = MAGIC_GRID + 1 integer, parameter, private :: MAGIC_GRID_END = MAGIC_GRID + 2 integer, parameter, private :: MAGIC_GRID_EMPTY = MAGIC_GRID + 3 integer, parameter, private :: MAGIC_GRID_MAP = MAGIC_GRID + 4 integer, parameter, private :: MAGIC_GRID_MU_X = MAGIC_GRID + 5 @ <>= subroutine read_grid_raw_unit (g, unit, read_integrals) type(vamp_grid), intent(inout) :: g integer, intent(in) :: unit logical, intent(in), optional :: read_integrals character(len=*), parameter :: FN = "vamp_read_raw_grid" integer :: ndim, i, j, magic read (unit = unit) magic if (magic /= MAGIC_GRID_BEGIN) then print *, FN, " fatal: expecting magic ", MAGIC_GRID_BEGIN, & ", found ", magic stop end if read (unit = unit) ndim <> call create_array_pointer (g%num_div, ndim) read (unit = unit) g%num_calls read (unit = unit) g%calls_per_cell read (unit = unit) g%stratified read (unit = unit) g%all_stratified read (unit = unit) g%quadrupole read (unit = unit) g%mu(1) read (unit = unit) g%mu(2) read (unit = unit) g%mu_plus(1) read (unit = unit) g%mu_plus(2) read (unit = unit) g%mu_minus(1) read (unit = unit) g%mu_minus(2) read (unit = unit) g%sum_integral read (unit = unit) g%sum_weights read (unit = unit) g%sum_chi2 read (unit = unit) g%calls read (unit = unit) g%dv2g read (unit = unit) g%jacobi read (unit = unit) g%f_min read (unit = unit) g%f_max read (unit = unit) g%mu_gi read (unit = unit) g%sum_mu_gi do i = 1, size (g%div) read (unit = unit) g%num_div(i) end do do i = 1, size (g%div) call read_division_raw (g%div(i), unit, read_integrals) end do read (unit = unit) magic if (magic == MAGIC_GRID_MAP) then call create_array_pointer (g%map, (/ ndim, ndim /)) do i = 1, size (g%div) do j = 1, size (g%div) read (unit = unit) g%map(i,j) end do end do else if (magic == MAGIC_GRID_EMPTY) then <> else print *, FN, " fatal: expecting magic ", MAGIC_GRID_EMPTY, & " or ", MAGIC_GRID_MAP, ", found ", magic stop end if read (unit = unit) magic if (magic == MAGIC_GRID_MU_X) then call create_array_pointer (g%mu_x, ndim ) call create_array_pointer (g%sum_mu_x, ndim) call create_array_pointer (g%mu_xx, (/ ndim, ndim /)) call create_array_pointer (g%sum_mu_xx, (/ ndim, ndim /)) do i = 1, size (g%div) read (unit = unit) g%mu_x(i) read (unit = unit) g%sum_mu_x(i) do j = 1, size (g%div) read (unit = unit) g%mu_xx(i,j) read (unit = unit) g%sum_mu_xx(i,j) end do end do else if (magic == MAGIC_GRID_EMPTY) then <> - else + else print *, FN, " fatal: expecting magic ", MAGIC_GRID_EMPTY, & " or ", MAGIC_GRID_MU_X, ", found ", magic stop end if read (unit = unit) magic if (magic /= MAGIC_GRID_END) then print *, FN, " fatal: expecting magic ", MAGIC_GRID_END, & " found ", magic stop end if end subroutine read_grid_raw_unit @ %def read_grid_raw_unit -@ +@ <>= subroutine write_grid_raw_name (g, name, write_integrals) type(vamp_grid), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: write_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "write", status = "replace", & form = "unformatted", file = name) call write_grid_raw_unit (g, unit, write_integrals) close (unit = unit) end subroutine write_grid_raw_name @ %def write_grid_raw_name -@ +@ <>= subroutine read_grid_raw_name (g, name, read_integrals) type(vamp_grid), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: read_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "read", status = "old", & form = "unformatted", file = name) call read_grid_raw_unit (g, unit, read_integrals) close (unit = unit) end subroutine read_grid_raw_name @ %def read_grid_raw_name @ <>= subroutine write_grids_raw_unit (g, unit, write_integrals) type(vamp_grids), intent(in) :: g integer, intent(in) :: unit logical, intent(in), optional :: write_integrals integer :: i write (unit = unit) MAGIC_GRIDS_BEGIN write (unit = unit) size (g%grids) write (unit = unit) g%sum_integral write (unit = unit) g%sum_weights write (unit = unit) g%sum_chi2 do i = 1, size (g%grids) write (unit = unit) g%weights(i) end do do i = 1, size (g%grids) write (unit = unit) g%num_calls(i) end do do i = 1, size (g%grids) call write_grid_raw_unit (g%grids(i), unit, write_integrals) end do write (unit = unit) MAGIC_GRIDS_END end subroutine write_grids_raw_unit @ %def write_grids_raw_unit @ <>= integer, parameter, private :: MAGIC_GRIDS = 33333333 integer, parameter, private :: MAGIC_GRIDS_BEGIN = MAGIC_GRIDS + 1 integer, parameter, private :: MAGIC_GRIDS_END = MAGIC_GRIDS + 2 @ <>= subroutine read_grids_raw_unit (g, unit, read_integrals) type(vamp_grids), intent(inout) :: g integer, intent(in) :: unit logical, intent(in), optional :: read_integrals character(len=*), parameter :: FN = "vamp_read_grids_raw" integer :: i, nch, magic read (unit = unit) magic if (magic /= MAGIC_GRIDS_BEGIN) then print *, FN, " fatal: expecting magic ", MAGIC_GRIDS_BEGIN, & " found ", magic stop end if read (unit = unit) nch if (associated (g%grids)) then if (size (g%grids) /= nch) then call vamp_delete_grid (g%grids) deallocate (g%grids, g%weights, g%num_calls) allocate (g%grids(nch), g%weights(nch), g%num_calls(nch)) call vamp_create_empty_grid (g%grids) end if else allocate (g%grids(nch), g%weights(nch), g%num_calls(nch)) call vamp_create_empty_grid (g%grids) end if read (unit = unit) g%sum_integral read (unit = unit) g%sum_weights read (unit = unit) g%sum_chi2 do i = 1, nch read (unit = unit) g%weights(i) end do do i = 1, nch read (unit = unit) g%num_calls(i) end do do i = 1, nch call read_grid_raw_unit (g%grids(i), unit, read_integrals) end do read (unit = unit) magic if (magic /= MAGIC_GRIDS_END) then print *, FN, " fatal: expecting magic ", MAGIC_GRIDS_END, & " found ", magic stop end if end subroutine read_grids_raw_unit @ %def read_grids_raw_unit -@ +@ <>= subroutine write_grids_raw_name (g, name, write_integrals) type(vamp_grids), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: write_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "write", status = "replace", & form = "unformatted", file = name) call write_grids_raw_unit (g, unit, write_integrals) close (unit = unit) end subroutine write_grids_raw_name @ %def write_grids_raw_name -@ +@ <>= subroutine read_grids_raw_name (g, name, read_integrals) type(vamp_grids), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: read_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "read", status = "old", & form = "unformatted", file = name) call read_grids_raw_unit (g, unit, read_integrals) close (unit = unit) end subroutine read_grids_raw_name @ %def read_grids_raw_name @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Marshaling} [WK] Note: [[mu_plus]] and [[mu_minus]] not transferred (hard-coded buffer indices)! <>= public :: vamp_marshal_grid_size, vamp_marshal_grid, vamp_unmarshal_grid -@ +@ <>= pure subroutine vamp_marshal_grid (g, ibuf, dbuf) type(vamp_grid), intent(in) :: g integer, dimension(:), intent(inout) :: ibuf real(kind=default), dimension(:), intent(inout) :: dbuf integer :: i, iwords, dwords, iidx, didx, ndim ndim = size (g%div) ibuf(1) = g%num_calls ibuf(2) = g%calls_per_cell ibuf(3) = ndim if (g%stratified) then ibuf(4) = 1 else ibuf(4) = 0 end if if (g%all_stratified) then ibuf(5) = 1 else ibuf(5) = 0 end if if (g%quadrupole) then ibuf(6) = 1 else ibuf(6) = 0 end if dbuf(1:2) = g%mu dbuf(3) = g%sum_integral dbuf(4) = g%sum_weights dbuf(5) = g%sum_chi2 dbuf(6) = g%calls dbuf(7) = g%dv2g dbuf(8) = g%jacobi dbuf(9) = g%f_min dbuf(10) = g%f_max dbuf(11) = g%mu_gi dbuf(12) = g%sum_mu_gi ibuf(7:6+ndim) = g%num_div iidx = 7 + ndim didx = 13 do i = 1, ndim call marshal_division_size (g%div(i), iwords, dwords) ibuf(iidx) = iwords ibuf(iidx+1) = dwords iidx = iidx + 2 call marshal_division (g%div(i), ibuf(iidx:iidx-1+iwords), & dbuf(didx:didx-1+dwords)) iidx = iidx + iwords didx = didx + dwords end do if (associated (g%map)) then ibuf(iidx) = 1 dbuf(didx:didx-1+ndim**2) = reshape (g%map, (/ ndim**2 /)) didx = didx + ndim**2 else ibuf(iidx) = 0 end if iidx = iidx + 1 if (associated (g%mu_x)) then ibuf(iidx) = 1 dbuf(didx:didx-1+ndim) = g%mu_x didx = didx + ndim dbuf(didx:didx-1+ndim) = g%sum_mu_x didx = didx + ndim dbuf(didx:didx-1+ndim**2) = reshape (g%mu_xx, (/ ndim**2 /)) didx = didx + ndim**2 dbuf(didx:didx-1+ndim**2) = reshape (g%sum_mu_xx, (/ ndim**2 /)) didx = didx + ndim**2 else ibuf(iidx) = 0 end if iidx = iidx + 1 end subroutine vamp_marshal_grid @ %def vamp_marshal_grid -@ +@ <>= pure subroutine vamp_marshal_grid_size (g, iwords, dwords) type(vamp_grid), intent(in) :: g integer, intent(out) :: iwords, dwords integer :: i, ndim, iw, dw ndim = size (g%div) iwords = 6 + ndim dwords = 12 do i = 1, ndim call marshal_division_size (g%div(i), iw, dw) iwords = iwords + 2 + iw dwords = dwords + dw end do iwords = iwords + 1 if (associated (g%map)) then dwords = dwords + ndim**2 end if iwords = iwords + 1 if (associated (g%mu_x)) then dwords = dwords + 2 * (ndim + ndim**2) end if end subroutine vamp_marshal_grid_size @ %def vamp_marshal_grid_size -@ +@ <>= pure subroutine vamp_unmarshal_grid (g, ibuf, dbuf) type(vamp_grid), intent(inout) :: g integer, dimension(:), intent(in) :: ibuf real(kind=default), dimension(:), intent(in) :: dbuf integer :: i, iwords, dwords, iidx, didx, ndim g%num_calls = ibuf(1) g%calls_per_cell = ibuf(2) ndim = ibuf(3) g%stratified = ibuf(4) /= 0 g%all_stratified = ibuf(5) /= 0 g%quadrupole = ibuf(6) /= 0 g%mu = dbuf(1:2) g%sum_integral = dbuf(3) g%sum_weights = dbuf(4) g%sum_chi2 = dbuf(5) g%calls = dbuf(6) g%dv2g = dbuf(7) g%jacobi = dbuf(8) g%f_min = dbuf(9) g%f_max = dbuf(10) g%mu_gi = dbuf(11) g%sum_mu_gi = dbuf(12) call copy_array_pointer (g%num_div, ibuf(7:6+ndim)) <> iidx = 7 + ndim didx = 13 do i = 1, ndim iwords = ibuf(iidx) dwords = ibuf(iidx+1) iidx = iidx + 2 call unmarshal_division (g%div(i), ibuf(iidx:iidx-1+iwords), & dbuf(didx:didx-1+dwords)) iidx = iidx + iwords didx = didx + dwords end do if (ibuf(iidx) > 0) then call copy_array_pointer & (g%map, reshape (dbuf(didx:didx-1+ibuf(iidx)), (/ ndim, ndim /))) didx = didx + ibuf(iidx) else <> end if iidx = iidx + 1 if (ibuf(iidx) > 0) then call copy_array_pointer (g%mu_x, dbuf(didx:didx-1+ndim)) didx = didx + ndim call copy_array_pointer (g%sum_mu_x, dbuf(didx:didx-1+ndim)) didx = didx + ndim call copy_array_pointer & (g%mu_xx, reshape (dbuf(didx:didx-1+ndim**2), (/ ndim, ndim /))) didx = didx + ndim**2 call copy_array_pointer & (g%sum_mu_xx, reshape (dbuf(didx:didx-1+ndim**2), (/ ndim, ndim /))) didx = didx + ndim**2 else <> end if iidx = iidx + 1 end subroutine vamp_unmarshal_grid @ %def vamp_unmarshal_grid -@ +@ <>= public :: vamp_marshal_history_size, vamp_marshal_history public :: vamp_unmarshal_history -@ +@ <>= pure subroutine vamp_marshal_history (h, ibuf, dbuf) type(vamp_history), intent(in) :: h integer, dimension(:), intent(inout) :: ibuf real(kind=default), dimension(:), intent(inout) :: dbuf integer :: j, ndim, iidx, didx, iwords, dwords if (h%verbose .and. (associated (h%div))) then ndim = size (h%div) else ndim = 0 end if ibuf(1) = ndim ibuf(2) = h%calls if (h%stratified) then ibuf(3) = 1 else ibuf(3) = 0 end if dbuf(1) = h%integral dbuf(2) = h%std_dev dbuf(3) = h%avg_integral dbuf(4) = h%avg_std_dev dbuf(5) = h%avg_chi2 dbuf(6) = h%f_min dbuf(7) = h%f_max iidx = 4 didx = 8 do j = 1, ndim call marshal_div_history_size (h%div(j), iwords, dwords) ibuf(iidx) = iwords ibuf(iidx+1) = dwords iidx = iidx + 2 call marshal_div_history (h%div(j), ibuf(iidx:iidx-1+iwords), & dbuf(didx:didx-1+dwords)) iidx = iidx + iwords didx = didx + dwords end do end subroutine vamp_marshal_history @ %def vamp_marshal_history -@ +@ <>= pure subroutine vamp_marshal_history_size (h, iwords, dwords) type(vamp_history), intent(in) :: h integer, intent(out) :: iwords, dwords integer :: i, ndim, iw, dw if (h%verbose .and. (associated (h%div))) then ndim = size (h%div) else ndim = 0 end if iwords = 3 dwords = 7 do i = 1, ndim call marshal_div_history_size (h%div(i), iw, dw) iwords = iwords + 2 + iw dwords = dwords + dw end do end subroutine vamp_marshal_history_size @ %def vamp_marshal_history_size -@ +@ <>= pure subroutine vamp_unmarshal_history (h, ibuf, dbuf) type(vamp_history), intent(inout) :: h integer, dimension(:), intent(in) :: ibuf real(kind=default), dimension(:), intent(in) :: dbuf integer :: j, ndim, iidx, didx, iwords, dwords ndim = ibuf(1) h%calls = ibuf(2) h%stratified = ibuf(3) /= 0 h%integral = dbuf(1) h%std_dev = dbuf(2) h%avg_integral = dbuf(3) h%avg_std_dev = dbuf(4) h%avg_chi2 = dbuf(5) h%f_min = dbuf(6) h%f_max = dbuf(7) if (ndim > 0) then if (associated (h%div)) then if (size (h%div) /= ndim) then deallocate (h%div) allocate (h%div(ndim)) end if else allocate (h%div(ndim)) end if iidx = 4 didx = 8 do j = 1, ndim iwords = ibuf(iidx) dwords = ibuf(iidx+1) iidx = iidx + 2 call unmarshal_div_history (h%div(j), ibuf(iidx:iidx-1+iwords), & dbuf(didx:didx-1+dwords)) iidx = iidx + iwords didx = didx + dwords end do end if end subroutine vamp_unmarshal_history @ %def vamp_unmarshal_history @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Boring Copying and Deleting of Objects} <>= elemental subroutine vamp_copy_grid (lhs, rhs) type(vamp_grid), intent(inout) :: lhs type(vamp_grid), intent(in) :: rhs integer :: ndim ndim = size (rhs%div) lhs%mu = rhs%mu lhs%mu_plus = rhs%mu_plus lhs%mu_minus = rhs%mu_minus lhs%sum_integral = rhs%sum_integral lhs%sum_weights = rhs%sum_weights lhs%sum_chi2 = rhs%sum_chi2 lhs%calls = rhs%calls lhs%num_calls = rhs%num_calls call copy_array_pointer (lhs%num_div, rhs%num_div) lhs%dv2g = rhs%dv2g lhs%jacobi = rhs%jacobi lhs%f_min = rhs%f_min lhs%f_max = rhs%f_max lhs%mu_gi = rhs%mu_gi lhs%sum_mu_gi = rhs%sum_mu_gi lhs%calls_per_cell = rhs%calls_per_cell lhs%stratified = rhs%stratified lhs%all_stratified = rhs%all_stratified lhs%quadrupole = rhs%quadrupole if (associated (lhs%div)) then if (size (lhs%div) /= ndim) then call delete_division (lhs%div) deallocate (lhs%div) allocate (lhs%div(ndim)) end if else allocate (lhs%div(ndim)) end if call copy_division (lhs%div, rhs%div) if (associated (rhs%map)) then call copy_array_pointer (lhs%map, rhs%map) else if (associated (lhs%map)) then deallocate (lhs%map) end if if (associated (rhs%mu_x)) then call copy_array_pointer (lhs%mu_x, rhs%mu_x) call copy_array_pointer (lhs%mu_xx, rhs%mu_xx) call copy_array_pointer (lhs%sum_mu_x, rhs%sum_mu_x) call copy_array_pointer (lhs%sum_mu_xx, rhs%sum_mu_xx) else if (associated (lhs%mu_x)) then deallocate (lhs%mu_x, lhs%mu_xx, lhs%sum_mu_x, lhs%sum_mu_xx) end if end subroutine vamp_copy_grid @ %def vamp_copy_grid @ <>= elemental subroutine vamp_delete_grid (g) type(vamp_grid), intent(inout) :: g if (associated (g%div)) then call delete_division (g%div) deallocate (g%div, g%num_div) end if if (associated (g%map)) then deallocate (g%map) end if if (associated (g%mu_x)) then deallocate (g%mu_x, g%mu_xx, g%sum_mu_x, g%sum_mu_xx) end if end subroutine vamp_delete_grid @ %def vamp_delete_grid @ <>= elemental subroutine vamp_copy_grids (lhs, rhs) type(vamp_grids), intent(inout) :: lhs type(vamp_grids), intent(in) :: rhs integer :: nch nch = size (rhs%grids) lhs%sum_integral = rhs%sum_integral lhs%sum_chi2 = rhs%sum_chi2 lhs%sum_weights = rhs%sum_weights if (associated (lhs%grids)) then if (size (lhs%grids) /= nch) then deallocate (lhs%grids) allocate (lhs%grids(nch)) call vamp_create_empty_grid (lhs%grids(nch)) end if else allocate (lhs%grids(nch)) call vamp_create_empty_grid (lhs%grids(nch)) end if call vamp_copy_grid (lhs%grids, rhs%grids) call copy_array_pointer (lhs%weights, rhs%weights) call copy_array_pointer (lhs%num_calls, rhs%num_calls) end subroutine vamp_copy_grids @ %def vamp_copy_grids @ <>= elemental subroutine vamp_delete_grids (g) type(vamp_grids), intent(inout) :: g if (associated (g%grids)) then call vamp_delete_grid (g%grids) deallocate (g%weights, g%grids, g%num_calls) end if end subroutine vamp_delete_grids @ %def vamp_delete_grids -@ +@ <>= elemental subroutine vamp_copy_history (lhs, rhs) type(vamp_history), intent(inout) :: lhs type(vamp_history), intent(in) :: rhs lhs%calls = rhs%calls lhs%stratified = rhs%stratified lhs%verbose = rhs%verbose lhs%integral = rhs%integral lhs%std_dev = rhs%std_dev lhs%avg_integral = rhs%avg_integral lhs%avg_std_dev = rhs%avg_std_dev lhs%avg_chi2 = rhs%avg_chi2 lhs%f_min = rhs%f_min lhs%f_max = rhs%f_max if (rhs%verbose) then if (associated (lhs%div)) then if (size (lhs%div) /= size (rhs%div)) then deallocate (lhs%div) allocate (lhs%div(size(rhs%div))) end if else allocate (lhs%div(size(rhs%div))) end if call copy_history (lhs%div, rhs%div) end if end subroutine vamp_copy_history @ %def vamp_copy_history -@ +@ <>= elemental subroutine vamp_delete_history (h) type(vamp_history), intent(inout) :: h if (associated (h%div)) then deallocate (h%div) end if end subroutine vamp_delete_history @ %def vamp_delete_history @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/src/vegas/vegas.nw =================================================================== --- trunk/src/vegas/vegas.nw (revision 8827) +++ trunk/src/vegas/vegas.nw (revision 8828) @@ -1,9889 +1,9907 @@ %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; noweb-code-mode: f90-mode -*- % WHIZARD code as NOWEB source: VEGAS algorithm %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{VEGAS Integration} \label{cha:vegas-integration} -@ The backbone integrator of WHIZARD is a object-oriented implemetation of the VEGAS algorithm. +@ The backbone integrator of WHIZARD is an object-oriented implemetation of the VEGAS algorithm. <<[[vegas.f90]]>>= <> module vegas <> <> <> <> <> <> <> interface <> end interface contains <> end module vegas @ %def vegas @ <<[[vegas_sub.f90]]>>= <> submodule (vegas) vegas_s implicit none contains <> end submodule vegas_s @ %def vegas_sub_s @ <>= use diagnostics use io_units use format_utils, only: write_indent use format_defs, only: FMT_17 use rng_base, only: rng_t use rng_stream, only: rng_stream_t @ @ MPI Module. <>= use request_callback, only: request_handler_t use mpi_f08 !NODEP! @ \section{Integration modes} \label{sec:integration-modes} VEGAS operates in three different modes: [[vegas_mode_importance_only]], [[vegas_mode_importance]] or [[vegas_mode_stratified]]. The default mode is [[vegas_mode_importance]], where the algorithm decides whether if it is possible to use importance sampling or stratified sampling. In low dimensions VEGAS uses strict stratified sampling. <>= integer, parameter, public :: VEGAS_MODE_IMPORTANCE = 0, & & VEGAS_MODE_STRATIFIED = 1, VEGAS_MODE_IMPORTANCE_ONLY = 2 @ %def vegas_mode_importance vegas_mode_stratified vegas_mode_importance_only @ \section{Type: vegas\_func\_t} \label{sec:type:vegas_func_t} We define a abstract [[func]] type which only gives an interface to an [[evaluate]] procedure. The inside of implementation and also the optimization of are not a concern of the [[vegas]] implementation. <>= public :: vegas_func_t <>= type, abstract :: vegas_func_t ! contains procedure(vegas_func_evaluate), deferred, pass, public :: evaluate end type vegas_func_t @ %def vegas_func_t @ The only procedure called in [[vegas]] is [[vegas_func_evaluate]]. It takes a real value [[x]] and returns a real value [[f]]. <>= abstract interface real(default) function vegas_func_evaluate (self, x) result (f) import :: default, vegas_func_t class(vegas_func_t), intent(inout) :: self real(default), dimension(:), intent(in) :: x end function vegas_func_evaluate end interface @ %def vegas_func_evaluate @ \section{Type: vegas\_config\_t} \label{sec:type:vegas_config_t} We store the complete configuration in a transparent container. The [[vegas_config_t]] object inside VEGAS must not be directly accesible. We provide a get method which returns a copy of the [[vegas_config_t]] object. Apart from the options which can be set by the constructor of [[vegas_t]] object, we store the run-time configuration [[n_calls]], [[calls_per_box]], [[n_bins]] and [[n_boxes]]. Those are calculated and set accordingly by VEGAS. <>= public :: vegas_config_t <>= type :: vegas_config_t integer :: n_dim = 0 real(default) :: alpha = 1.5_default integer :: n_bins_max = 50 integer :: iterations = 5 integer :: mode = VEGAS_MODE_STRATIFIED integer :: calls_per_box = 0 integer :: n_calls = 0 integer :: n_calls_min = 20 integer :: n_boxes = 1 integer :: n_bins = 1 contains <> end type vegas_config_t @ %def vegas_config_t, n_calls, calls_per_box, n_bins, n_boxes @ Write out the configuration of the grid. <>= procedure, public :: write => vegas_config_write <>= module subroutine vegas_config_write (self, unit, indent) class(vegas_config_t), intent(in) :: self integer, intent(in), optional :: unit integer, intent(in), optional :: indent end subroutine vegas_config_write <>= module subroutine vegas_config_write (self, unit, indent) class(vegas_config_t), intent(in) :: self integer, intent(in), optional :: unit integer, intent(in), optional :: indent integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call write_indent (u, ind) write (u, "(2x,A,I0)") & & "Number of dimensions = ", self%n_dim call write_indent (u, ind) write (u, "(2x,A," // FMT_17 // ")") & & "Adaption power (alpha) = ", self%alpha call write_indent (u, ind) write (u, "(2x,A,I0)") & & "Max. number of bins (per dim.) = ", self%n_bins_max call write_indent (u, ind) write (u, "(2x,A,I0)") & & "Number of iterations = ", self%iterations call write_indent (u, ind) write (u, "(2x,A,I0)") & & "Mode (stratified or importance) = ", self%mode call write_indent (u, ind) write (u, "(2x,A,I0)") & & "Calls per box = ", self%calls_per_box call write_indent (u, ind) write (u, "(2x,A,I0)") & & "Number of calls = ", self%n_calls call write_indent (u, ind) write (u, "(2x,A,I0)") & & "Min. number of calls = ", self%n_calls_min call write_indent (u, ind) write (u, "(2x,A,I0)") & & "Number of bins = ", self%n_bins call write_indent (u, ind) write (u, "(2x,A,I0)") & & "Number of boxes = ", self%n_boxes end subroutine vegas_config_write @ %def vegas_config_write @ \section{Type: vegas\_grid\_t} \label{sec:type:-vegas_g} We provide a simple and transparent grid container. The container can then later be used, to export the actual grid. <>= public :: vegas_grid_t <>= type :: vegas_grid_t integer :: n_dim = 1 integer :: n_bins = 1 real(default), dimension(:), allocatable :: x_lower real(default), dimension(:), allocatable :: x_upper real(default), dimension(:), allocatable :: delta_x real(default), dimension(:,:), allocatable :: xi contains <> end type vegas_grid_t @ %def vegas_grid_t @ Initialise grid. <>= interface vegas_grid_t module procedure vegas_grid_init end interface vegas_grid_t <>= module function vegas_grid_init (n_dim, n_bins_max) result (self) type(vegas_grid_t) :: self integer, intent(in) :: n_dim integer, intent(in) :: n_bins_max end function vegas_grid_init <>= module function vegas_grid_init (n_dim, n_bins_max) result (self) type(vegas_grid_t) :: self integer, intent(in) :: n_dim integer, intent(in) :: n_bins_max self%n_dim = n_dim self%n_bins = 1 allocate (self%x_upper(n_dim), source=1.0_default) allocate (self%x_lower(n_dim), source=0.0_default) allocate (self%delta_x(n_dim), source=1.0_default) allocate (self%xi((n_bins_max + 1), n_dim), source=0.0_default) end function vegas_grid_init @ %def vegas_grid_init @ Output. <>= procedure, public :: write => vegas_grid_write <>= module subroutine vegas_grid_write (self, unit, pacify) class(vegas_grid_t), intent(in) :: self integer, intent(in), optional :: unit logical, intent(in), optional :: pacify end subroutine vegas_grid_write <>= module subroutine vegas_grid_write (self, unit, pacify) class(vegas_grid_t), intent(in) :: self integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical :: pac integer :: u, i, j pac = .false.; if (present (pacify)) pac = pacify u = given_output_unit (unit) write (u, descr_fmt) "begin vegas_grid_t" write (u, integer_fmt) "n_dim = ", self%n_dim write (u, integer_fmt) "n_bins = ", self%n_bins write (u, descr_fmt) "begin x_lower" - do j = 1, self%n_dim - if (pac) then - write (u, double_array_pac_fmt) j, self%x_lower(j) - else - write (u, double_array_fmt) j, self%x_lower(j) - end if - end do + if (allocated (self%x_lower)) then + do j = 1, self%n_dim + if (pac) then + write (u, double_array_pac_fmt) j, self%x_lower(j) + else + write (u, double_array_fmt) j, self%x_lower(j) + end if + end do + end if write (u, descr_fmt) "end x_lower" write (u, descr_fmt) "begin x_upper" - do j = 1, self%n_dim - if (pac) then - write (u, double_array_pac_fmt) j, self%x_upper(j) - else - write (u, double_array_fmt) j, self%x_upper(j) - end if - end do + if (allocated (self%x_upper)) then + do j = 1, self%n_dim + if (pac) then + write (u, double_array_pac_fmt) j, self%x_upper(j) + else + write (u, double_array_fmt) j, self%x_upper(j) + end if + end do + end if write (u, descr_fmt) "end x_upper" write (u, descr_fmt) "begin delta_x" - do j = 1, self%n_dim - if (pac) then - write (u, double_array_pac_fmt) j, self%delta_x(j) - else - write (u, double_array_fmt) j, self%delta_x(j) - end if - end do - write (u, descr_fmt) "end delta_x" - write (u, descr_fmt) "begin xi" - do j = 1, self%n_dim - do i = 1, self%n_bins + 1 + if (allocated (self%delta_x)) then + do j = 1, self%n_dim if (pac) then - write (u, double_array2_pac_fmt) i, j, self%xi(i, j) + write (u, double_array_pac_fmt) j, self%delta_x(j) else - write (u, double_array2_fmt) i, j, self%xi(i, j) + write (u, double_array_fmt) j, self%delta_x(j) end if end do - end do + end if + write (u, descr_fmt) "end delta_x" + write (u, descr_fmt) "begin xi" + if (allocated (self%xi)) then + do j = 1, self%n_dim + do i = 1, self%n_bins + 1 + if (pac) then + write (u, double_array2_pac_fmt) i, j, self%xi(i, j) + else + write (u, double_array2_fmt) i, j, self%xi(i, j) + end if + end do + end do + end if write (u, descr_fmt) "end xi" write (u, descr_fmt) "end vegas_grid_t" end subroutine vegas_grid_write @ %def vegas_grid_write @ Compare two grids, if they match up to an given precision. <>= public :: operator (==) <>= interface operator (==) module procedure vegas_grid_equal end interface operator (==) <>= module function vegas_grid_equal (grid_a, grid_b) result (yorn) logical :: yorn type(vegas_grid_t), intent(in) :: grid_a, grid_b end function vegas_grid_equal <>= module function vegas_grid_equal (grid_a, grid_b) result (yorn) logical :: yorn type(vegas_grid_t), intent(in) :: grid_a, grid_b yorn = .true. yorn = yorn .and. (grid_a%n_dim == grid_b%n_dim) yorn = yorn .and. (grid_a%n_bins == grid_b%n_bins) yorn = yorn .and. all (grid_a%x_lower == grid_b%x_lower) yorn = yorn .and. all (grid_a%x_upper == grid_b%x_upper) yorn = yorn .and. all (grid_a%delta_x == grid_b%delta_x) yorn = yorn .and. all (grid_a%xi == grid_b%xi) end function vegas_grid_equal @ %def vegas_grid_equal @ Resize each bin accordingly to its corresponding weight [[w]]. Can be used to resize the grid to a new size of bins or refinement. The procedure expects two arguments, firstly, [[n_bins]] and, secondly, the refinement weights [[w]]. If [[n_bins]] differs from the internally stored one, we resize the grid under consideration of [[w]]. If each element of [[w]] equals one, then the bins are resized preserving their original bin density. Anytime else, we refine the grid accordingly to [[w]]. <>= procedure, private :: resize => vegas_grid_resize <>= module subroutine vegas_grid_resize (self, n_bins, w) class(vegas_grid_t), intent(inout) :: self integer, intent(in) :: n_bins real(default), dimension(:, :), intent(in) :: w end subroutine vegas_grid_resize <>= module subroutine vegas_grid_resize (self, n_bins, w) class(vegas_grid_t), intent(inout) :: self integer, intent(in) :: n_bins real(default), dimension(:, :), intent(in) :: w real(default), dimension(size(self%xi)) :: xi_new integer :: i, j, k real(default) :: pts_per_bin real(default) :: d_width do j = 1, self%n_dim if (self%n_bins /= n_bins) then pts_per_bin = real(self%n_bins, default) / real(n_bins, default) self%n_bins = n_bins else if (all (w(:, j) == 0.)) then call msg_bug ("[VEGAS] grid_resize: resize weights are zero.") end if pts_per_bin = sum(w(:, j)) / self%n_bins end if d_width = 0. k = 0 do i = 2, self%n_bins do while (pts_per_bin > d_width) k = k + 1 d_width = d_width + w(k, j) end do d_width = d_width - pts_per_bin associate (x_upper => self%xi(k + 1, j), x_lower => self%xi(k, j)) xi_new(i) = x_upper - (x_upper - x_lower) * d_width / w(k, j) end associate end do self%xi(:, j) = 0. ! Reset grid explicitly self%xi(2:n_bins, j) = xi_new(2:n_bins) self%xi(n_bins + 1, j) = 1. end do end subroutine vegas_grid_resize @ %def vegas_grid_resize @ Find the probability for a given [[x]] in the unit hypercube. For the case [[n_bins < N_BINARY_SEARCH]], we utilize linear search which is faster for short arrays. Else we make use of a binary search. Furthermore, we calculate the inverse of the probability and invert the result only at the end (saving some time on division). <>= procedure, public :: get_probability => vegas_grid_get_probability <>= module function vegas_grid_get_probability (self, x) result (g) class(vegas_grid_t), intent(in) :: self real(default), dimension(:), intent(in) :: x real(default) :: g end function vegas_grid_get_probability <>= module function vegas_grid_get_probability (self, x) result (g) class(vegas_grid_t), intent(in) :: self real(default), dimension(:), intent(in) :: x real(default) :: g integer :: j, i_lower, i_higher, i_mid real(default), dimension(size(x)) :: y g = 1 y = (x - self%x_lower) / self%delta_x if (any (y < 0 .or. y > 1)) then g = 0; return end if ndim: do j = 1, self%n_dim i_lower = 1 i_higher = self%n_bins + 1 !! Left-most search search: do while (i_lower < i_higher - 1) i_mid = floor ((i_higher + i_lower) / 2.) if (y(j) > self%xi(i_mid, j)) then i_lower = i_mid else i_higher = i_mid end if end do search g = g * (self%delta_x(j) * & & self%n_bins * (self%xi(i_lower + 1, j) - self%xi(i_lower, j))) end do ndim ! Move division to the end, which is more efficient. if (g /= 0) g = 1 / g end function vegas_grid_get_probability @ %def vegas_grid_get_probability @ Broadcast the grid information. As safety measure, we get the actual grid object from VEGAS (correclty allocated, but for non-root unfilled) and broadcast the root object. On success, we set grid into VEGAS. We use the non-blocking broadcast routine, because we have to send quite a bunch of integers and reals. We have to be very careful with [[n_bins]], the number of bins can actually change during different iterations. If we reuse a grid, we have to take that, every grid uses the same [[n_bins]]. We expect, that the number of dimension does not change, which is in principle possible, but will be checked onto in [[vegas_set_grid]]. <>= procedure, public :: broadcast => vegas_grid_broadcast <>= module subroutine vegas_grid_broadcast (self, comm) class(vegas_grid_t), intent(inout) :: self type(MPI_COMM), intent(in) :: comm end subroutine vegas_grid_broadcast <>= module subroutine vegas_grid_broadcast (self, comm) class(vegas_grid_t), intent(inout) :: self type(MPI_COMM), intent(in) :: comm integer :: j, ierror type(MPI_Request), dimension(self%n_dim + 4) :: status ! Blocking call MPI_Bcast (self%n_bins, 1, MPI_INTEGER, 0, comm) ! Non blocking call MPI_Ibcast (self%n_dim, 1, MPI_INTEGER, 0, comm, status(1)) call MPI_Ibcast (self%x_lower, self%n_dim, & & MPI_DOUBLE_PRECISION, 0, comm, status(2)) call MPI_Ibcast (self%x_upper, self%n_dim, & & MPI_DOUBLE_PRECISION, 0, comm, status(3)) call MPI_Ibcast (self%delta_x, self%n_dim, & & MPI_DOUBLE_PRECISION, 0, comm, status(4)) ndim: do j = 1, self%n_dim call MPI_Ibcast (self%xi(1:self%n_bins + 1, j), self%n_bins + 1,& & MPI_DOUBLE_PRECISION, 0, comm, status(4 + j)) end do ndim call MPI_Waitall (self%n_dim + 4, status, MPI_STATUSES_IGNORE) end subroutine vegas_grid_broadcast @ %def vegas_grid_broadcast @ \section{Type: vegas\_result\_t} \label{sec:type:-vegas_r} We store the result of the latest iteration(s) in a transparent container. The [[vegas_result_t]] object inside VEGAS must not be directly accessible. We export the a copy of the result via a get-method of the [[vegas_t]] object. -We store latest event weight in [[evt_weight]] and a (possible) evebt weight +We store latest event weight in [[evt_weight]] and a (possible) event weight excess in [[evt_weight_excess]], if the event weight is larger than [[max_abs_f]]. <>= public :: vegas_result_t <>= type :: vegas_result_t integer :: it_start = 0 integer :: it_num = 0 integer :: samples = 0 real(default) :: sum_int_wgtd = 0._default real(default) :: sum_wgts real(default) :: sum_chi = 0._default real(default) :: chi2 = 0._default real(default) :: efficiency = 0._default real(default) :: efficiency_pos = 0._default real(default) :: efficiency_neg = 0._default real(default) :: max_abs_f = 0._default real(default) :: max_abs_f_pos = 0._default real(default) :: max_abs_f_neg = 0._default real(default) :: result = 0._default real(default) :: std = 0._default real(default) :: evt_weight = 0._default real(default) :: evt_weight_excess = 0._default contains <> end type vegas_result_t @ %def vegas_results_t @ Write out the current status of the integration result. <>= procedure, public :: write => vegas_result_write <>= module subroutine vegas_result_write (self, unit, indent) class(vegas_result_t), intent(in) :: self integer, intent(in), optional :: unit integer, intent(in), optional :: indent end subroutine vegas_result_write <>= module subroutine vegas_result_write (self, unit, indent) class(vegas_result_t), intent(in) :: self integer, intent(in), optional :: unit integer, intent(in), optional :: indent integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call write_indent (u, ind) write (u, "(2x,A,I0)") & & "Start iteration = ", self%it_start call write_indent (u, ind) write (u, "(2x,A,I0)") & & "Iteration number = ", self%it_num call write_indent (u, ind) write (u, "(2x,A,I0)") & & "Sample number = ", self%samples call write_indent (u, ind) write (u, "(2x,A," // FMT_17 //")") & & "Sum of weighted integrals = ", self%sum_int_wgtd call write_indent (u, ind) write (u, "(2x,A," // FMT_17 // ")") & & "Sum of weights = ", self%sum_wgts call write_indent (u, ind) write (u, "(2x,A," // FMT_17 // ")") & & "Sum of chi = ", self%sum_chi call write_indent (u, ind) write (u, "(2x,A," // FMT_17 // ")") & & "chi2 = ", self%chi2 call write_indent (u, ind) write (u, "(2x,A," // FMT_17 // ")") & & "Overall efficiency = ", self%efficiency call write_indent (u, ind) write (u, "(2x,A," // FMT_17 // ")") & & "f-positive efficiency = ", self%efficiency_pos call write_indent (u, ind) write (u, "(2x,A," // FMT_17 // ")") & & "f-negative efficiency = ", self%efficiency_neg call write_indent (u, ind) write (u, "(2x,A," // FMT_17 // ")") & & "Maximum absolute overall value = ", self%max_abs_f call write_indent (u, ind) write (u, "(2x,A," // FMT_17 // ")") & & "Maximum absolute positive value = ", self%max_abs_f_pos call write_indent (u, ind) write (u, "(2x,A," // FMT_17 // ")") & & "Maximum absolute negative value = ", self%max_abs_f_neg call write_indent (u, ind) write (u, "(2x,A," // FMT_17 // ")") & & "Integral (of latest iteration) = ", self%result call write_indent (u, ind) write (u, "(2x,A," // FMT_17 // ")") & & "Standard deviation = ", self%std write (u, "(2x,A," // FMT_17 // ")") & & "Event weight = ", self%evt_weight write (u, "(2x,A," // FMT_17 // ")") & & "Event weight excess = ", self%evt_weight_excess end subroutine vegas_result_write @ %def vegas_results_write @ Update results and efficiency. We define \begin{equation} \operatorname*{max}_{x} w(x) = \frac{f(x)}{p(x)} \Delta_{\text{jac}}. \end{equation} In the implementation we have to factor out [[n_calls]] in the jacobian. Also, during event generation. <>= procedure, public :: update => vegas_result_update procedure, public :: update_efficiency => vegas_result_update_efficiency <>= module subroutine vegas_result_update (result, integral, variance) class(vegas_result_t), intent(inout) :: result real(default), intent(in) :: integral real(default), intent(in) :: variance end subroutine vegas_result_update module subroutine vegas_result_update_efficiency (result, & n_calls, max_pos, max_neg, sum_pos, sum_neg) class(vegas_result_t), intent(inout) :: result integer, intent(in) :: n_calls real(default), intent(in) :: max_pos real(default), intent(in) :: max_neg real(default), intent(in) :: sum_pos real(default), intent(in) :: sum_neg end subroutine vegas_result_update_efficiency <>= module subroutine vegas_result_update (result, integral, variance) class(vegas_result_t), intent(inout) :: result real(default), intent(in) :: integral real(default), intent(in) :: variance real(default) :: guarded_variance, sq_integral real(default) :: wgt, chi !! Guard against zero (or negative) variance. !! \Delta = I * \epsilon -> I = \Delta. if (variance < & max ((epsilon (integral) * integral)**2, tiny(integral))) then guarded_variance = & max ((epsilon (integral) * integral)**2, & tiny (integral)) else guarded_variance = variance end if wgt = 1._default / guarded_variance sq_integral = integral**2 result%result = integral result%std = sqrt (guarded_variance) result%samples = result%samples + 1 if (result%samples == 1) then result%chi2 = 0._default else chi = integral if (result%sum_wgts > 0) then chi = chi - result%sum_int_wgtd / result%sum_wgts end if result%chi2 = result%chi2 * (result%samples - 2.0_default) result%chi2 = (wgt / (1._default + (wgt / result%sum_wgts))) & & * chi**2 result%chi2 = result%chi2 / (result%samples - 1._default) end if result%sum_wgts = result%sum_wgts + wgt result%sum_int_wgtd = result%sum_int_wgtd + (integral * wgt) result%sum_chi = result%sum_chi + (sq_integral * wgt) end subroutine vegas_result_update module subroutine vegas_result_update_efficiency (result, & n_calls, max_pos, max_neg, sum_pos, sum_neg) class(vegas_result_t), intent(inout) :: result integer, intent(in) :: n_calls real(default), intent(in) :: max_pos real(default), intent(in) :: max_neg real(default), intent(in) :: sum_pos real(default), intent(in) :: sum_neg result%max_abs_f_pos = n_calls * max_pos result%max_abs_f_neg = n_calls * max_neg result%max_abs_f = & & max (result%max_abs_f_pos, result%max_abs_f_neg) result%efficiency_pos = 0 if (max_pos > 0) then result%efficiency_pos = & & sum_pos / max_pos end if result%efficiency_neg = 0 if (max_neg > 0) then result%efficiency_neg = & & sum_neg / max_neg end if result%efficiency = 0 if (result%max_abs_f > 0.) then result%efficiency = (sum_pos + sum_neg) & & / result%max_abs_f end if end subroutine vegas_result_update_efficiency @ %def vegas_result_update, vegas_result_update_efficiency @ Reset results. <>= procedure, public :: reset => vegas_result_reset <>= module subroutine vegas_result_reset (result) class(vegas_result_t), intent(inout) :: result end subroutine vegas_result_reset <>= module subroutine vegas_result_reset (result) class(vegas_result_t), intent(inout) :: result result%sum_int_wgtd = 0 result%sum_wgts = 0 result%sum_chi = 0 result%it_num = 0 result%samples = 0 result%chi2 = 0 result%efficiency = 0 result%efficiency_pos = 0 result%efficiency_neg = 0 result%max_abs_f = 0 result%max_abs_f_pos = 0 result%max_abs_f_neg = 0 end subroutine vegas_result_reset @ %def vegas_result_reset @ Send the result object to specified rank, internally in a non-blocking way. We do not need to handle the event results, because each event result is atomic. <>= procedure, public :: send => vegas_result_send <>= module subroutine vegas_result_send (self, receiver, tag, comm, request) class(vegas_result_t), intent(in) :: self integer, intent(in) :: receiver integer, intent(in) :: tag type(MPI_COMM), intent(in) :: comm type(MPI_Request), dimension(:), intent(inout) :: request end subroutine vegas_result_send <>= module subroutine vegas_result_send (self, receiver, tag, comm, request) class(vegas_result_t), intent(in) :: self integer, intent(in) :: receiver integer, intent(in) :: tag type(MPI_COMM), intent(in) :: comm type(MPI_Request), dimension(:), intent(inout) :: request if (size (request) /= self%get_n_requests ()) & call msg_bug ("VEGAS: number of requests does not match.") call MPI_Isend (self%it_start, 1, MPI_INTEGER, receiver, tag + 1,& & comm, request(1)) call MPI_Isend (self%it_num, 1, MPI_INTEGER, receiver , tag + 2,& & comm, request(2)) call MPI_Isend (self%samples, 1, MPI_INTEGER, receiver, tag + 3,& & comm, request(3)) call MPI_Isend (self%sum_int_wgtd, 1, MPI_DOUBLE_PRECISION, receiver, tag + 4,& & comm, request(4)) call MPI_Isend (self%sum_wgts, 1, MPI_DOUBLE_PRECISION, receiver, tag + 5,& & comm, request(5)) call MPI_Isend (self%sum_chi, 1, MPI_DOUBLE_PRECISION, receiver, tag + 6,& & comm, request(6)) call MPI_Isend (self%chi2, 1, MPI_DOUBLE_PRECISION, receiver, tag + 7,& & comm, request(7)) call MPI_Isend (self%efficiency, 1, MPI_DOUBLE_PRECISION, receiver, tag + 8,& & comm, request(8)) call MPI_Isend (self%efficiency_pos, 1, MPI_DOUBLE_PRECISION, receiver, tag + 9,& & comm, request(9)) call MPI_Isend (self%efficiency_neg, 1, MPI_DOUBLE_PRECISION, receiver, tag + 10,& & comm, request(10)) call MPI_Isend (self%max_abs_f, 1, MPI_DOUBLE_PRECISION, receiver, tag + 11,& & comm, request(11)) call MPI_Isend (self%max_abs_f_pos, 1, MPI_DOUBLE_PRECISION, receiver, tag + 12,& & comm, request(12)) call MPI_Isend (self%max_abs_f_neg, 1, MPI_DOUBLE_PRECISION, receiver, tag + 13,& & comm, request(13)) call MPI_Isend (self%result, 1, MPI_DOUBLE_PRECISION, receiver, tag + 14,& & comm, request(14)) call MPI_Isend (self%std, 1, MPI_DOUBLE_PRECISION, receiver, tag + 15,& & comm, request(15)) end subroutine vegas_result_send @ %def vegas_result_communicate @ Receive the result object from a specified rank, internally in a non-blocking way. <>= procedure, public :: receive => vegas_result_receive <>= module subroutine vegas_result_receive (self, sender, tag, comm, request) class(vegas_result_t), intent(inout) :: self integer, intent(in) :: sender integer, intent(in) :: tag type(MPI_COMM), intent(in) :: comm type(MPI_REQUEST), dimension(:), intent(inout) :: request end subroutine vegas_result_receive <>= module subroutine vegas_result_receive (self, sender, tag, comm, request) class(vegas_result_t), intent(inout) :: self integer, intent(in) :: sender integer, intent(in) :: tag type(MPI_COMM), intent(in) :: comm type(MPI_REQUEST), dimension(:), intent(inout) :: request if (size (request) /= self%get_n_requests ()) & call msg_bug ("VEGAS: number of requests does not match.") call MPI_Irecv (self%it_start, 1, MPI_INTEGER, sender, tag + 1,& & comm, request(1)) call MPI_Irecv (self%it_num, 1, MPI_INTEGER, sender , tag + 2,& & comm, request(2)) call MPI_Irecv (self%samples, 1, MPI_INTEGER, sender, tag + 3,& & comm, request(3)) call MPI_Irecv (self%sum_int_wgtd, 1, MPI_DOUBLE_PRECISION, sender, tag + 4,& & comm, request(4)) call MPI_Irecv (self%sum_wgts, 1, MPI_DOUBLE_PRECISION, sender, tag + 5,& & comm, request(5)) call MPI_Irecv (self%sum_chi, 1, MPI_DOUBLE_PRECISION, sender, tag + 6,& & comm, request(6)) call MPI_Irecv (self%chi2, 1, MPI_DOUBLE_PRECISION, sender, tag + 7,& & comm, request(7)) call MPI_Irecv (self%efficiency, 1, MPI_DOUBLE_PRECISION, sender, tag + 8,& & comm, request(8)) call MPI_Irecv (self%efficiency_pos, 1, MPI_DOUBLE_PRECISION, sender, tag + 9,& & comm, request(9)) call MPI_Irecv (self%efficiency_neg, 1, MPI_DOUBLE_PRECISION, sender, tag + 10,& & comm, request(10)) call MPI_Irecv (self%max_abs_f, 1, MPI_DOUBLE_PRECISION, sender, tag + 11,& & comm, request(11)) call MPI_Irecv (self%max_abs_f_pos, 1, MPI_DOUBLE_PRECISION, sender, tag + 12,& & comm, request(12)) call MPI_Irecv (self%max_abs_f_neg, 1, MPI_DOUBLE_PRECISION, sender, tag + 13,& & comm, request(13)) call MPI_Irecv (self%result, 1, MPI_DOUBLE_PRECISION, sender, tag + 14,& & comm, request(14)) call MPI_Irecv (self%std, 1, MPI_DOUBLE_PRECISION, sender, tag + 15,& & comm, request(15)) end subroutine vegas_result_receive @ %def vegas_result_receive @ <>= procedure, private :: get_n_requests => vegas_result_get_n_requests <>= pure module function vegas_result_get_n_requests (result) result (n_requests) class(vegas_result_t), intent(in) :: result integer :: n_requests end function vegas_result_get_n_requests <>= pure module function vegas_result_get_n_requests (result) result (n_requests) class(vegas_result_t), intent(in) :: result integer :: n_requests n_requests = 15 end function vegas_result_get_n_requests @ %def vegas_result_get_n_requests @ \section{Type: vegas\_handler\_t} \label{sec:vegas_handler_t} Callback handler for VEGAS result and grid. <>= public :: vegas_handler_t <>= type, extends(request_handler_t) :: vegas_handler_t type(vegas_result_t), pointer :: result => null () real(default), dimension(:, :), pointer :: d => null () contains <> end type vegas_handler_t @ %def vegas_handler_t @ Provide the actual communication between master and client. The communication for [[vegas_result_t]] is done in a separate procedure, where we only have to pass the MPI requests. Collecting of the distribution array is done directly. <>= procedure :: init => vegas_handler_init procedure :: write => vegas_handler_write procedure :: handle => vegas_handler_handle procedure :: client_handle => vegas_handler_client_handle final :: vegas_handler_final <>= module subroutine vegas_handler_init (handler, handler_id, result, d) class(vegas_handler_t), intent(inout) :: handler integer, intent(in) :: handler_id type(vegas_result_t), intent(in), target :: result real(default), dimension(:, :), intent(in), target :: d end subroutine vegas_handler_init module subroutine vegas_handler_write (handler, unit) class(vegas_handler_t), intent(in) :: handler integer, intent(in), optional :: unit end subroutine vegas_handler_write module subroutine vegas_handler_client_handle (handler, dest_rank, comm) class(vegas_handler_t), intent(inout) :: handler integer, intent(in) :: dest_rank type(MPI_COMM), intent(in) :: comm end subroutine vegas_handler_client_handle module subroutine vegas_handler_handle (handler, source_rank, comm) class(vegas_handler_t), intent(inout) :: handler integer, intent(in) :: source_rank type(MPI_COMM), intent(in) :: comm end subroutine vegas_handler_handle module subroutine vegas_handler_final (handler) type(vegas_handler_t), intent(inout) :: handler end subroutine vegas_handler_final <>= module subroutine vegas_handler_init (handler, handler_id, result, d) class(vegas_handler_t), intent(inout) :: handler integer, intent(in) :: handler_id type(vegas_result_t), intent(in), target :: result real(default), dimension(:, :), intent(in), target :: d integer :: n_requests, tag_offset handler%result => result handler%d => d handler%finished = .false. !! Add one request for handling of the distribution d. n_requests = result%get_n_requests () + 1 tag_offset = max(handler_id - 1, 0) * n_requests call handler%allocate (n_requests, tag_offset) end subroutine vegas_handler_init module subroutine vegas_handler_write (handler, unit) class(vegas_handler_t), intent(in) :: handler integer, intent(in), optional :: unit integer :: u, j u = given_output_unit (unit) write (u, "(A)") "[VEGAS_HANDLER]" call handler%base_write (unit) call handler%result%write (u) write (u, "(A)") "BEGIN D" do j = 1, size (handler%d, dim=2) write (u, "(1X,I3,999(1X," // FMT_17 // "))") j, handler%d(:, j) end do write (u, "(A)") "END D" end subroutine vegas_handler_write module subroutine vegas_handler_handle (handler, source_rank, comm) class(vegas_handler_t), intent(inout) :: handler integer, intent(in) :: source_rank type(MPI_COMM), intent(in) :: comm !! Take the complete contiguous array memory. call MPI_Irecv (handler%d, size (handler%d),& & MPI_DOUBLE_PRECISION, source_rank, handler%tag_offset, comm,& & handler%request(1)) call handler%result%receive (source_rank, handler%tag_offset, comm, & handler%request(2:)) handler%activated = .true. handler%finished = .false. end subroutine vegas_handler_handle module subroutine vegas_handler_client_handle (handler, dest_rank, comm) class(vegas_handler_t), intent(inout) :: handler integer, intent(in) :: dest_rank type(MPI_COMM), intent(in) :: comm !! Take the complete contiguous array memory. call MPI_Isend (handler%d, size (handler%d),& & MPI_DOUBLE_PRECISION, dest_rank, handler%tag_offset, comm,& & handler%request(1)) call handler%result%send (dest_rank, handler%tag_offset, comm, & handler%request(2:)) handler%activated = .true. handler%finished = .false. end subroutine vegas_handler_client_handle !> Finalize vegas_handler_t. !! !! Nullify pointer to object. module subroutine vegas_handler_final (handler) type(vegas_handler_t), intent(inout) :: handler nullify (handler%result) nullify (handler%d) end subroutine vegas_handler_final @ %def vegas_handler_init, vegas_handler_write, vegas_handler_handle, @ %def vegas_handler_client_handle, vegas_handler_final @ \section{Type: vegas\_t} \label{sec:type:-vegas_t} The VEGAS object contains the methods for integration and grid resize- and refinement. We store the grid configuration and the (current) result in transparent containers alongside with the actual grid and the distribution. The values of the distribution depend on the chosen mode whether the function value or the variance is stored. The distribution is used after each iteration to refine the grid. <>= public :: vegas_t <>= type :: vegas_t private type(vegas_config_t) :: config real(default) :: hypercube_volume = 0._default real(default) :: jacobian = 0._default real(default), dimension(:, :), allocatable :: d type(vegas_grid_t) :: grid integer, dimension(:), allocatable :: bin integer, dimension(:), allocatable :: box type(vegas_result_t) :: result <> contains <> end type vegas_t @ %def vegas_t @ Add members for MPI communication and parallel mode. Must be set before calling to [[vegas_integrate]], likewise [[vegas_set_calls]]. <>= type(MPI_COMM) :: comm logical :: parallel_mode = .false. @ We overload the type constructor of [[vegas_t]] which initialises the mandatory argument [[n_dim]] and allocate memory for the grid. <>= interface vegas_t module procedure vegas_init end interface vegas_t <>= module function vegas_init & (n_dim, alpha, n_bins_max, iterations, mode) result (self) type(vegas_t) :: self integer, intent(in) :: n_dim integer, intent(in), optional :: n_bins_max real(default), intent(in), optional :: alpha integer, intent(in), optional :: iterations integer, intent(in), optional :: mode end function vegas_init <>= module function vegas_init & (n_dim, alpha, n_bins_max, iterations, mode) result (self) type(vegas_t) :: self integer, intent(in) :: n_dim integer, intent(in), optional :: n_bins_max real(default), intent(in), optional :: alpha integer, intent(in), optional :: iterations integer, intent(in), optional :: mode self%config%n_dim = n_dim if (present (alpha)) self%config%alpha = alpha if (present (n_bins_max)) self%config%n_bins_max = n_bins_max if (present (iterations)) self%config%iterations = iterations if (present (mode)) self%config%mode = mode self%grid = vegas_grid_t (n_dim, self%config%n_bins_max) allocate (self%d(self%config%n_bins_max, n_dim), source=0.0_default) allocate (self%box(n_dim), source=1) allocate (self%bin(n_dim), source=1) self%config%n_bins = 1 self%config%n_boxes = 1 call self%set_limits (self%grid%x_lower, self%grid%x_upper) call self%reset_grid () call self%reset_result () <> end function vegas_init @ %def vegas_init <>= @ @ Prepare VEGAS to be run in parallel modues (when compiled with MPI). <>= call self%prepare_parallel_integrate (MPI_COMM_WORLD, & duplicate_comm = .false., & parallel_mode = .true.) @ @ Finalize the grid. Deallocate grid memory. <>= procedure, public :: final => vegas_final <>= module subroutine vegas_final (self) class(vegas_t), intent(inout) :: self end subroutine vegas_final <>= module subroutine vegas_final (self) class(vegas_t), intent(inout) :: self deallocate (self%grid%x_upper) deallocate (self%grid%x_lower) deallocate (self%grid%delta_x) deallocate (self%d) deallocate (self%grid%xi) deallocate (self%box) deallocate (self%bin) end subroutine vegas_final @ %def vegas_final \section{Get-/Set-methods} \label{sec:set-get-methods} @ The VEGAS object prohibits direct access from outside. Communication is handle via get- or set-methods. Set the limits of integration. The defaults limits correspong the $n$-dimensionl unit hypercube. \textit{Remark:} After setting the limits, the grid is initialised, again. Previous results are lost due to recalculation of the overall jacobian. <>= procedure, public :: set_limits => vegas_set_limits <>= module subroutine vegas_set_limits (self, x_lower, x_upper) class(vegas_t), intent(inout) :: self real(default), dimension(:), intent(in) :: x_lower real(default), dimension(:), intent(in) :: x_upper end subroutine vegas_set_limits <>= module subroutine vegas_set_limits (self, x_lower, x_upper) class(vegas_t), intent(inout) :: self real(default), dimension(:), intent(in) :: x_lower real(default), dimension(:), intent(in) :: x_upper if (size (x_lower) /= self%config%n_dim & & .or. size (x_upper) /= self%config%n_dim) then write (msg_buffer, "(A, I5, A, I5, A, I5)") & "VEGAS: [set_limits] n_dim of new lower/upper integration limit& & does not match previously set n_dim. ", self%config%n_dim, " =/=& & ", size (x_lower), " =/= ", size (x_upper) call msg_fatal () end if if (any(x_upper < x_lower)) then call msg_fatal ("VEGAS: [set_limits] upper limits are smaller than lower limits.") end if if (any((x_upper - x_lower) > huge(0._default))) then call msg_fatal ("VEGAS: [set_limits] upper and lower limits exceed rendering.") end if self%grid%x_upper = x_upper self%grid%x_lower = x_lower self%grid%delta_x = self%grid%x_upper - self%grid%x_lower self%hypercube_volume = product (self%grid%delta_x) call self%reset_result () end subroutine vegas_set_limits @ %def vegas_set_limits @ Set the number of calls. If the number of calls changed during different passes, we resize the grid preserving the probability density. We should reset the results after changing the number of calls which change the size of the grid and the running mode of VEGAS. But, this is a set method only for the number of calls. <>= procedure, public :: set_calls => vegas_set_n_calls <>= module subroutine vegas_set_n_calls (self, n_calls) class(vegas_t), intent(inout) :: self integer, intent(in) :: n_calls end subroutine vegas_set_n_calls <>= module subroutine vegas_set_n_calls (self, n_calls) class(vegas_t), intent(inout) :: self integer, intent(in) :: n_calls if (.not. (n_calls > 0)) then write (msg_buffer, "(A, I5)") & "VEGAS: [set_calls] number of calls must be a positive number. Keep& & number of calls = ", self%config%n_calls call msg_warning () else self%config%n_calls = max (n_calls, self%config%n_calls_min) if (self%config%n_calls /= n_calls) then write (msg_buffer, "(A,I5)") & "VEGAS: [set calls] number of calls is too few, reset to ", self%config%n_calls call msg_warning () end if call self%init_grid () end if end subroutine vegas_set_n_calls @ %def vegas_set_n_calls @ Get the grid object and set [[n_bins]], [[n_dim]] inside grid container. <>= procedure, public :: get_grid => vegas_get_grid <>= module function vegas_get_grid (self) result (grid) class(vegas_t), intent(in) :: self type(vegas_grid_t) :: grid end function vegas_get_grid <>= module function vegas_get_grid (self) result (grid) class(vegas_t), intent(in) :: self type(vegas_grid_t) :: grid grid = self%grid grid%n_dim = self%config%n_dim grid%n_bins = self%config%n_bins end function vegas_get_grid @ %def vegas_get_grid @ Set grid. We need a set method for the parallelisation. We do some additional checks before copying the object. Be careful, we do not check on [[n_bins]], because the number of bins can change after setting [[n_calls]]. We remind you, that you will loose all your current progress, if you use set the grid. Hence, it will only be used when compiled with [[MPI]]. <>= procedure, public :: set_grid => vegas_set_grid <>= module subroutine vegas_set_grid (self, grid) class(vegas_t), intent(inout) :: self type(vegas_grid_t), intent(in) :: grid end subroutine vegas_set_grid <>= module subroutine vegas_set_grid (self, grid) class(vegas_t), intent(inout) :: self type(vegas_grid_t), intent(in) :: grid integer :: j logical :: success success = .true. success = (success .and. (grid%n_dim .eq. self%config%n_dim)) success = (success .and. all (grid%x_lower .eq. self%grid%x_lower)) success = (success .and. all (grid%x_upper .eq. self%grid%x_upper)) success = (success .and. all (grid%delta_x .eq. self%grid%delta_x)) if (success) then self%config%n_bins = grid%n_bins do j = 1, self%config%n_dim self%grid%xi(1, j) = 0._default self%grid%xi(2:self%config%n_bins, j) = grid%xi(2:grid%n_bins, j) self%grid%xi(self%config%n_bins + 1, j) = 1._default end do else call msg_bug ("VEGAS: set grid: boundary conditions do not match.") end if end subroutine vegas_set_grid @ %def vegas_set_grid @ Prepare a parallel integration. A parallel integration requires a communicator, which may be duplicated in order to provide a safe communication context for the current VEGAS instance. Furthermore, given an optional parameter, the behavior with regards to the parallel evaluation can be changed (e.g. embbed integration). <>= procedure, public :: prepare_parallel_integrate => & vegas_prepare_parallel_integrate <>= module subroutine vegas_prepare_parallel_integrate & (self, comm, duplicate_comm, parallel_mode) class(vegas_t), intent(inout) :: self type(MPI_COMM), intent(in) :: comm logical, intent(in), optional :: duplicate_comm logical, intent(in), optional :: parallel_mode end subroutine vegas_prepare_parallel_integrate <>= module subroutine vegas_prepare_parallel_integrate & (self, comm, duplicate_comm, parallel_mode) class(vegas_t), intent(inout) :: self type(MPI_COMM), intent(in) :: comm logical, intent(in), optional :: duplicate_comm logical, intent(in), optional :: parallel_mode logical :: flag flag = .true.; if (present (duplicate_comm)) flag = duplicate_comm if (duplicate_comm) then call MPI_COMM_DUP (comm, self%comm) else self%comm = comm end if self%parallel_mode = .true.; if (present (parallel_mode)) & self%parallel_mode = parallel_mode end subroutine vegas_prepare_parallel_integrate @ %def vegas_prepare_parallel_integrate @ We check if it is senseful to parallelize the actual grid. In simple, this means that [[n_boxes]] has to be larger than 2. With the result that we could have an actual superimposed stratified grid. In advance, we can give the size of communicator [[n_size]] and check whether we have enough boxes to distribute. <>= procedure, public :: is_parallelizable => vegas_is_parallelizable <>= elemental module function vegas_is_parallelizable & (self, opt_n_size) result (flag) class(vegas_t), intent(in) :: self logical :: flag integer, intent(in), optional :: opt_n_size end function vegas_is_parallelizable <>= elemental module function vegas_is_parallelizable & (self, opt_n_size) result (flag) class(vegas_t), intent(in) :: self logical :: flag integer, intent(in), optional :: opt_n_size integer :: n_size n_size = 2; if (present (opt_n_size)) n_size = opt_n_size flag = (self%config%n_boxes**floor (self%config%n_dim / 2.) >= n_size) end function vegas_is_parallelizable @ %def vegas_is_parallelizable @ Get the config object. <>= procedure, public :: get_config => vegas_get_config <>= module subroutine vegas_get_config (self, config) class(vegas_t), intent(in) :: self type(vegas_config_t), intent(out) :: config end subroutine vegas_get_config <>= module subroutine vegas_get_config (self, config) class(vegas_t), intent(in) :: self type(vegas_config_t), intent(out) :: config config = self%config end subroutine vegas_get_config @ %def vegas_get_config @ Set non-runtime dependent configuration. It will no be possible to change [[n_bins_max]]. <>= procedure, public :: set_config => vegas_set_config <>= module subroutine vegas_set_config (self, config) class(vegas_t), intent(inout) :: self class(vegas_config_t), intent(in) :: config end subroutine vegas_set_config <>= module subroutine vegas_set_config (self, config) class(vegas_t), intent(inout) :: self class(vegas_config_t), intent(in) :: config self%config%alpha = config%alpha self%config%iterations = config%iterations self%config%mode = config%mode self%config%n_calls_min = config%n_calls_min end subroutine vegas_set_config @ %def vegas_set_config @ Get the result object. <>= procedure, public :: get_result => vegas_get_result <>= module function vegas_get_result (self) result (result) type(vegas_result_t) :: result class(vegas_t), intent(in) :: self end function vegas_get_result <>= module function vegas_get_result (self) result (result) type(vegas_result_t) :: result class(vegas_t), intent(in) :: self result = self%result end function vegas_get_result @ %def vegas_get_result @ Set the result object. Be reminded, that you will loose your current results, if you are not careful! Hence, it will only be avaible during usage with [[MPI]]. <>= procedure, public :: set_result => vegas_set_result <>= module subroutine vegas_set_result (self, result) class(vegas_t), intent(inout) :: self type(vegas_result_t), intent(in) :: result end subroutine vegas_set_result <>= module subroutine vegas_set_result (self, result) class(vegas_t), intent(inout) :: self type(vegas_result_t), intent(in) :: result self%result = result end subroutine vegas_set_result @ %def vegas_set_result @ Get (actual) number of calls. <>= procedure, public :: get_calls => vegas_get_n_calls <>= elemental module function vegas_get_n_calls (self) result (n_calls) class(vegas_t), intent(in) :: self real(default) :: n_calls end function vegas_get_n_calls <>= elemental module function vegas_get_n_calls (self) result (n_calls) class(vegas_t), intent(in) :: self real(default) :: n_calls n_calls = self%config%n_calls end function vegas_get_n_calls @ %def vegas_get_n_calls @ Get the cumulative result of the integration. Recalculate weighted average of the integration. <>= procedure, public :: get_integral => vegas_get_integral <>= elemental module function vegas_get_integral (self) result (integral) class(vegas_t), intent(in) :: self real(default) :: integral end function vegas_get_integral <>= elemental module function vegas_get_integral (self) result (integral) class(vegas_t), intent(in) :: self real(default) :: integral integral = 0. if (self%result%sum_wgts > 0.) then integral = self%result%sum_int_wgtd / self%result%sum_wgts end if end function vegas_get_integral @ %def vegas_get_integral @ Get the cumulative variance of the integration. Recalculate the variance. <>= procedure, public :: get_variance => vegas_get_variance <>= elemental module function vegas_get_variance (self) result (variance) class(vegas_t), intent(in) :: self real(default) :: variance end function vegas_get_variance <>= elemental module function vegas_get_variance (self) result (variance) class(vegas_t), intent(in) :: self real(default) :: variance variance = 0. if (self%result%sum_wgts > 0.) then variance = 1.0 / self%result%sum_wgts end if end function vegas_get_variance @ %def vegas_get_variance @ Get efficiency. <>= procedure, public :: get_efficiency => vegas_get_efficiency <>= elemental module function vegas_get_efficiency (self) result (efficiency) class(vegas_t), intent(in) :: self real(default) :: efficiency end function vegas_get_efficiency <>= elemental module function vegas_get_efficiency (self) result (efficiency) class(vegas_t), intent(in) :: self real(default) :: efficiency efficiency = 0. if (self%result%efficiency > 0. ) then efficiency = self%result%efficiency end if end function vegas_get_efficiency @ %def vegas_get_efficiency @ Get [[f_max]]. <>= procedure, public :: get_max_abs_f => vegas_get_max_abs_f <>= elemental module function vegas_get_max_abs_f (self) result (max_abs_f) class(vegas_t), intent(in) :: self real(default) :: max_abs_f end function vegas_get_max_abs_f <>= elemental module function vegas_get_max_abs_f (self) result (max_abs_f) class(vegas_t), intent(in) :: self real(default) :: max_abs_f max_abs_f = 0. if (self%result%max_abs_f > 0.) then max_abs_f = self%result%max_abs_f end if end function vegas_get_max_abs_f @ %def vegas_get_max_abs_f @ Get sum of absolute (positive and negative) values. <>= procedure, public :: get_sum_abs_f_pos => vegas_get_sum_abs_f_pos procedure, public :: get_sum_abs_f_neg => vegas_get_sum_abs_f_neg <>= elemental module function vegas_get_sum_abs_f_pos (self) result (sum_abs_f) class(vegas_t), intent(in) :: self real(default) :: sum_abs_f end function vegas_get_sum_abs_f_pos - elemental module function vegas_get_sum_abs_f_neg (self) result (sum_abs_f) + elemental module function vegas_get_sum_abs_f_neg (self) result (sum_abs_f) class(vegas_t), intent(in) :: self real(default) :: sum_abs_f end function vegas_get_sum_abs_f_neg <>= elemental module function vegas_get_sum_abs_f_pos (self) result (sum_abs_f) class(vegas_t), intent(in) :: self real(default) :: sum_abs_f sum_abs_f = self%result%efficiency_pos * self%result%max_abs_f_pos end function vegas_get_sum_abs_f_pos - elemental module function vegas_get_sum_abs_f_neg (self) result (sum_abs_f) + elemental module function vegas_get_sum_abs_f_neg (self) result (sum_abs_f) class(vegas_t), intent(in) :: self real(default) :: sum_abs_f sum_abs_f = self%result%efficiency_neg * self%result%max_abs_f_neg end function vegas_get_sum_abs_f_neg @ %def vegas_get_sum_abs_f_pos, vegas_get_sum_abs_f_neg @ Get [[f_max_pos]]. <>= <>= procedure, public :: get_max_abs_f_pos => vegas_get_max_abs_f_pos <>= elemental module function vegas_get_max_abs_f_pos (self) result (max_abs_f) class(vegas_t), intent(in) :: self real(default) :: max_abs_f end function vegas_get_max_abs_f_pos <>= elemental module function vegas_get_max_abs_f_pos (self) result (max_abs_f) class(vegas_t), intent(in) :: self real(default) :: max_abs_f max_abs_f = 0. if (self%result%max_abs_f_pos > 0.) then max_abs_f = self%result%max_abs_f_pos end if end function vegas_get_max_abs_f_pos @ %def vegas_get_max_abs_f_pos @ Get [[f_max_neg]]. <>= procedure, public :: get_max_abs_f_neg => vegas_get_max_abs_f_neg <>= elemental module function vegas_get_max_abs_f_neg (self) result (max_abs_f) class(vegas_t), intent(in) :: self real(default) :: max_abs_f end function vegas_get_max_abs_f_neg <>= elemental module function vegas_get_max_abs_f_neg (self) result (max_abs_f) class(vegas_t), intent(in) :: self real(default) :: max_abs_f max_abs_f = 0. if (self%result%max_abs_f_neg > 0.) then max_abs_f = self%result%max_abs_f_neg end if end function vegas_get_max_abs_f_neg @ %def vegas_get_max_abs_f_neg @ Get event weight and excess. <>= procedure, public :: get_evt_weight => vegas_get_evt_weight procedure, public :: get_evt_weight_excess => vegas_get_evt_weight_excess <>= module function vegas_get_evt_weight (self) result (evt_weight) class(vegas_t), intent(in) :: self real(default) :: evt_weight end function vegas_get_evt_weight module function vegas_get_evt_weight_excess (self) result (evt_weight_excess) class(vegas_t), intent(in) :: self real(default) :: evt_weight_excess end function vegas_get_evt_weight_excess <>= module function vegas_get_evt_weight (self) result (evt_weight) class(vegas_t), intent(in) :: self real(default) :: evt_weight evt_weight = self%result%evt_weight end function vegas_get_evt_weight module function vegas_get_evt_weight_excess (self) result (evt_weight_excess) class(vegas_t), intent(in) :: self real(default) :: evt_weight_excess evt_weight_excess = self%result%evt_weight_excess end function vegas_get_evt_weight_excess @ %def vegas_get_evt_weight, vegas_get_evt_weight_excess @ Get and set distribution. We allow the distribution to be manipulated by an external call. The integration result cannot be changed by this, however, the error behavior may worsen and the efficiency may fall pretty low. But, also, the opposite is possible, see [[vamp2_equivalences]]. <>= procedure, public :: get_distribution => vegas_get_distribution procedure, public :: set_distribution => vegas_set_distribution <>= module function vegas_get_distribution (self) result (d) class(vegas_t), intent(in) :: self real(default), dimension(:, :), allocatable :: d end function vegas_get_distribution module subroutine vegas_set_distribution (self, d) class(vegas_t), intent(inout) :: self real(default), dimension(:, :), intent(in) :: d end subroutine vegas_set_distribution <>= module function vegas_get_distribution (self) result (d) class(vegas_t), intent(in) :: self real(default), dimension(:, :), allocatable :: d d = self%d end function vegas_get_distribution module subroutine vegas_set_distribution (self, d) class(vegas_t), intent(inout) :: self real(default), dimension(:, :), intent(in) :: d if (size (d, dim = 2) /= self%config%n_dim) then call msg_bug ("[VEGAS] set_distribution: new distribution has wrong size of dimension") end if if (size (d, dim = 1) /= self%config%n_bins_max) then call msg_bug ("[VEGAS] set_distribution: new distribution has wrong number of bins") end if self%d = d end subroutine vegas_set_distribution @ %def vegas_get_distribution, vegas_set_distribution @ Allocate result handler from VEGAS integrator object. Gfortran 7/8/9 bug, has to remain in the main module: <>= procedure, public :: allocate_handler => vegas_allocate_handler <>= subroutine vegas_allocate_handler (self, handler_id, handler) class(vegas_t), intent(in), target :: self integer, intent(in) :: handler_id class(request_handler_t), pointer, intent(out) :: handler allocate (vegas_handler_t :: handler) select type (handler) type is (vegas_handler_t) call handler%init (handler_id, result = self%result, d = self%d) end select end subroutine vegas_allocate_handler @ %def vegas_allocate_handler @ \section{Grid resize- and refinement} \label{sec:grid-resize-refin} Before integration the grid itself must be initialised. Given the number of [[n_calls]] and [[n_dim]] we prepare the grid for the integration. The grid is binned according to the VEGAS mode and [[n_calls]]. If the mode is not set to [[vegas_importance_only]], the grid is divided in to equal boxes. We try for 2 calls per box \begin{equation} boxes = \sqrt[n_{dim}]{\frac{calls}{2}}. \end{equation} If the numbers of boxes exceeds the number of bins, which is the case for low dimensions, the algorithm switches to stratified sampling. Otherwise, we are still using importance sampling, but keep the boxes for book keeping. If the number of bins changes from the previous invocation, bins are expanded or contracted accordingly, while preserving bin density. <>= procedure, private :: init_grid => vegas_init_grid <>= module subroutine vegas_init_grid (self) class(vegas_t), intent(inout) :: self end subroutine vegas_init_grid <>= module subroutine vegas_init_grid (self) class(vegas_t), intent(inout) :: self integer :: n_bins, n_boxes, box_per_bin, n_total_boxes real(default), dimension(:, :), allocatable :: w n_bins = self%config%n_bins_max n_boxes = 1 if (self%config%mode /= VEGAS_MODE_IMPORTANCE_ONLY) then ! We try for 2 calls per box n_boxes = max (floor ((self%config%n_calls / 2.)**(1. / self%config%n_dim)), 1) self%config%mode = VEGAS_MODE_IMPORTANCE if (2 * n_boxes >= self%config%n_bins_max) then ! if n_bins/box < 2 box_per_bin = max (n_boxes / self%config%n_bins_max, 1) n_bins = min (n_boxes / box_per_bin, self%config%n_bins_max) n_boxes = box_per_bin * n_bins self%config%mode = VEGAS_MODE_STRATIFIED end if end if n_total_boxes = n_boxes**self%config%n_dim self%config%calls_per_box = max (floor (real (self%config%n_calls) / n_total_boxes), 2) self%config%n_calls = self%config%calls_per_box * n_total_boxes ! Total volume of x-space/(average n_calls per bin) self%jacobian = self%hypercube_volume * real(n_bins, default)& &**self%config%n_dim / real(self%config%n_calls, default) self%config%n_boxes = n_boxes if (n_bins /= self%config%n_bins) then allocate (w(self%config%n_bins, self%config%n_dim), source=1.0_default) call self%grid%resize (n_bins, w) self%config%n_bins = n_bins end if end subroutine vegas_init_grid @ %def vegas_init_grid @ Reset the cumulative result, and efficiency and max. grid values. <>= procedure, public :: reset_result => vegas_reset_result <>= module subroutine vegas_reset_result (self) class(vegas_t), intent(inout) :: self end subroutine vegas_reset_result <>= module subroutine vegas_reset_result (self) class(vegas_t), intent(inout) :: self call self%result%reset () end subroutine vegas_reset_result @ %def vegas_reset_results @ Reset the grid. Purge the adapted grid and the distribution. Furthermore, reset the results. The maximal size of the grid remains. Note: Handle [[vegas_reset_grid]] with great care! Instead of reusing an old object, create a new one. <>= procedure, public :: reset_grid => vegas_reset_grid <>= module subroutine vegas_reset_grid (self) class(vegas_t), intent(inout) :: self end subroutine vegas_reset_grid <>= module subroutine vegas_reset_grid (self) class(vegas_t), intent(inout) :: self self%config%n_bins = 1 self%d = 0._default self%grid%xi = 0._default self%grid%xi(1, :) = 0._default self%grid%xi(2, :) = 1._default call self%reset_result () end subroutine vegas_reset_grid @ %def vegas_reset_grid @ Refine the grid to match the distribution [[d]]. Average the distribution over neighbouring bins, then contract or expand the bins. The averaging dampens high fluctuations amog the integrand or the variance. We make the type-bound procedure public accessible because the multi-channel integration refines each grid after integration over all grids. <>= procedure, public :: refine => vegas_refine_grid <>= module subroutine vegas_refine_grid (self, average) class(vegas_t), intent(inout) :: self logical, intent(in), optional :: average end subroutine vegas_refine_grid <>= module subroutine vegas_refine_grid (self, average) class(vegas_t), intent(inout) :: self logical, intent(in), optional :: average logical :: opt_average opt_average = .true.; if (present (average)) opt_average = average if (opt_average) call self%average_distribution () call self%grid%resize (self%config%n_bins, self%d(:self%config%n_bins, :)) end subroutine vegas_refine_grid @ %def vegas_refine_grid @ We average the collected values [[d]] of the (sq.) weighted [[f]] over neighbouring bins. The averaged [[d]] are then agian damped by a logarithm to enhance numerical stability. The results are then the refinement weights [[w]]. We have to take care of the special case where we have a very low sampling rate. In those cases we can not be sure that the distribution is satisfying filled, although we have already averaged over neighbouring bins. This will lead to a squashing of the unfilled bins and such the boundaries of those will be pushed together. We circumvent this problem by setting those unfilled bins to the smallest representable value of a default real. The problem becomes very annoying in the multi-channel formualae where have to look up via binary search the corresponding probability of [[x]] and if the width is zero, the point will be neglected. Another issue arises when [[NaN]]s appear during sampling. A single [[NaN]] may spoil the complete adaption as the refinement depends on all weights for a single axis, c.f. [[vegas_grid_resize]] for the details of the mechanism. Therefore, if we find a single (or more) [[NaN]]s in the distribution of an axis, then we won't adapt that specific axis by setting the weights to one. Hence, we skip the adaption for parts of the grid, where [[NaN]] appeared during evaluation. <>= procedure, private :: average_distribution => vegas_average_distribution <>= module subroutine vegas_average_distribution (self) class(vegas_t), intent(inout) :: self end subroutine vegas_average_distribution <>= module subroutine vegas_average_distribution (self) !! use, intrinsic :: ieee_arithmetic, only: ieee_is_nan class(vegas_t), intent(inout) :: self integer :: j ndim: do j = 1, self%config%n_dim associate (d => self%d(:self%config%n_bins, j), & n_bins => self%config%n_bins) !! Non-portable and compiler-flag sensistive test, may replace with ieee_is_nan if (any (d /= d)) then d = 1.0_default cycle ndim end if if (n_bins > 2) then d(1) = (d(1) + d(2)) / 2.0_default d(2:n_bins - 1) = (d(1:n_bins - 2) + d(2:n_bins - 1) + d(3:n_bins)) /& & 3.0_default d(n_bins) = d(n_bins - 1) + d(n_bins) / 2.0_default end if if (all (d < tiny (d))) then d = 1.0_default; cycle ndim end if d = d / sum (d) where (d < tiny (1.0_default)) d = tiny (1.0_default) end where where (d /= 1.0_default) d = ((d - 1.0_default) / log(d))**self%config%alpha elsewhere ! Analytic limes for d -> 1 d = 1.0_default end where end associate end do ndim end subroutine vegas_average_distribution @ %def vegas_average_distribution @ \section{Integration} \label{sec:integration} Integrate [[func]], in the previous set bounds [[x_lower]] to [[x_upper]], with [[n_calls]]. Use results from previous invocations of [[integrate]] with [[opt_reset_result = .false.]] and better with subsequent calls. Before we walk through the hybercube, we initialise the grid (at a central position). We step through the (equidistant) boxes which ensure we do not miss any place in the n-dim. hypercube. In each box we sample [[calls_per_box]] random points and transform them to bin coordinates. The total integral and the total (sample) variance over each box $i$ is then calculated by \begin{align*} E(I)_{i} = \sum_{j}^{\text{calls per box}} I_{i, j}, \\ V(I)_{i} = \text{calls per box} \frac{\sum_{j}^{\text{calls per box}}} I_{i, j}^{2} - (\sum_{j}^{\text{calls per box}} I_{i, j})**2 \frac{\text{calls per box}}{\text{calls per box} - 1}. \end{align*} The stratification of the $n$-dimensional hybercube allows a simple parallelisation of the algorithm (R. Kreckel, "Parallelization of adaptive MC integrators", Computer Physics Communications, vol. 106, no. 3, pp. 258–266, Nov. 1997.). We have to ensure that all boxes are sampled, but the number of boxes to distribute is too large. We allow each thread to sample a fraction $r$ of all boxes $k$ such that $r \ll k$. Furthermore, we constrain that the number of process $p$ is much smaller than $r$. The overall constraint is \begin{equation} p \ll r \ll k. \end{equation} We divide the intgeration into a parallel and a perpendicular subspace. The number of parallel dimensions is $D_{\parallel} = \lfloor \frac{D}{2} \rfloor$. <>= procedure, public :: integrate => vegas_integrate <>= module subroutine vegas_integrate (self, func, rng, iterations, reset_result, & refine_grid, verbose, result, abserr) class(vegas_t), intent(inout) :: self class(vegas_func_t), intent(inout) :: func class(rng_t), intent(inout) :: rng integer, intent(in), optional :: iterations logical, intent(in), optional :: reset_result logical, intent(in), optional :: refine_grid logical, intent(in), optional :: verbose real(default), optional, intent(out) :: result, abserr end subroutine vegas_integrate <>= module subroutine vegas_integrate (self, func, rng, iterations, reset_result, & refine_grid, verbose, result, abserr) class(vegas_t), intent(inout) :: self class(vegas_func_t), intent(inout) :: func class(rng_t), intent(inout) :: rng integer, intent(in), optional :: iterations logical, intent(in), optional :: reset_result logical, intent(in), optional :: refine_grid logical, intent(in), optional :: verbose real(default), optional, intent(out) :: result, abserr integer :: it, k real(default), dimension(self%config%n_dim) :: x real(default) :: fval, fval_sq, bin_volume real(default) :: fval_box, fval_sq_box real(default) :: total_integral, total_sq_integral real(default) :: cumulative_int, cumulative_std real(default) :: sum_abs_f_pos, max_abs_f_pos real(default) :: sum_abs_f_neg, max_abs_f_neg logical :: opt_reset_result logical :: opt_refine_grid logical :: opt_verbose integer :: n_size integer :: n_dim_par logical :: box_success <> call set_options () call self%init_grid () if (opt_reset_result) call self%result%reset () self%result%it_start = self%result%it_num cumulative_int = 0. cumulative_std = 0. n_dim_par = floor (self%config%n_dim / 2.) n_size = 1 <> if (opt_verbose) then call msg_message ("Results: [it, calls, integral, error, chi^2, eff.]") end if iteration: do it = 1, self%config%iterations self%result%it_num = self%result%it_start + it self%d = 0. self%box = 1 self%bin = 1 total_integral = 0. total_sq_integral = 0. sum_abs_f_pos = 0. max_abs_f_pos = 0. sum_abs_f_neg = 0. max_abs_f_neg = 0. box_success = .true. select type (rng) type is (rng_stream_t) call rng%next_substream () end select <> loop_over_par_boxes: do while (box_success) loop_over_perp_boxes: do while (box_success) fval_box = 0._default fval_sq_box = 0._default do k = 1, self%config%calls_per_box call self%random_point (rng, x, bin_volume) ! Call the function, yeah, call it... fval = self%jacobian * bin_volume * func%evaluate (x) fval_sq = fval**2 fval_box = fval_box + fval fval_sq_box = fval_sq_box + fval_sq if (fval > 0.) then max_abs_f_pos = max(abs (fval), max_abs_f_pos) sum_abs_f_pos = sum_abs_f_pos + abs(fval) else max_abs_f_neg = max(abs (fval), max_abs_f_neg) sum_abs_f_neg = sum_abs_f_neg + abs(fval) end if if (self%config%mode /= VEGAS_MODE_STRATIFIED) then call self%accumulate_distribution (fval_sq) end if end do fval_sq_box = sqrt (fval_sq_box * self%config%calls_per_box) ! (a - b) * (a + b) = a**2 - b**2 fval_sq_box = (fval_sq_box - fval_box) * (fval_sq_box + fval_box) if (fval_sq_box <= 0.0) fval_sq_box = fval_box**2 * epsilon (1.0_default) total_integral = total_integral + fval_box total_sq_integral = total_sq_integral + fval_sq_box if (self%config%mode == VEGAS_MODE_STRATIFIED) then call self%accumulate_distribution (fval_sq_box) end if call increment_box_coord (self%box(n_dim_par + 1:self%config& &%n_dim), box_success) end do loop_over_perp_boxes shift: do k = 1, n_size call increment_box_coord (self%box(1:n_dim_par), box_success) if (.not. box_success) exit shift end do shift <> end do loop_over_par_boxes <> associate (result => self%result) ! Compute final results for this iterations call result%update (total_integral, variance = & total_sq_integral / (self%config%calls_per_box - 1._default)) call result%update_efficiency (n_calls = self%config%n_calls, & max_pos = max_abs_f_pos, max_neg = max_abs_f_neg, & sum_pos = sum_abs_f_pos, sum_neg = sum_abs_f_neg) cumulative_int = result%sum_int_wgtd / result%sum_wgts cumulative_std = sqrt (1 / result%sum_wgts) end associate if (opt_verbose) then write (msg_buffer, "(I0,1x,I0,1x, 4(E24.16E4,1x))") & & it, self%config%n_calls, cumulative_int, cumulative_std, & & self%result%chi2, self%result%efficiency call msg_message () end if if (opt_refine_grid) then call self%refine (average = .true.) else !! Skip grid refinement, but average the (grid) distribution. !! \note Now, we always average and dampen the distribution, !! even when not adapting (e.g. final pass). call self%average_distribution () end if end do iteration if (present(result)) result = cumulative_int if (present(abserr)) abserr = abs(cumulative_std) contains <> end subroutine vegas_integrate @ %def vegas_integrate @ Set optional arguments of [[vegas_integrate]]. <>= subroutine set_options () if (present (iterations)) self%config%iterations = iterations opt_reset_result = .true. if (present (reset_result)) opt_reset_result = reset_result opt_refine_grid = .true. if (present (refine_grid)) opt_refine_grid = refine_grid opt_verbose = .false. if (present (verbose)) opt_verbose = verbose end subroutine set_options @ We define additional chunk, which will be used later on for inserting MPI/general MPI code. The code is then removed by additional noweb filter if not compiled with the correspondig compiler flag. Overall variables, some additionally introduced due to the MPI parallelization and needed in sequentiell verison. <>= @ @ Overall initialization. <>= @ @ Reset all last-iteration results before sampling. <>= @ @ Adjust rng between parallel and perpendicular loops. <>= @ <>= @ Increment the box coordinates by 1. If we reach the largest value for the current axis (starting with the largest dimension number), we reset the counter to 1 and increment the next axis counter by 1. And so on, until we reach the maximum counter value of the axis with the lowest dimension, then we set [[success]] to false and the box coord is set to 1. <>= subroutine increment_box_coord (box, success) integer, dimension(:), intent(inout) :: box logical, intent(out) :: success integer :: j success = .true. do j = size (box), 1, -1 box(j) = box(j) + 1 if (box(j) <= self%config%n_boxes) return box(j) = 1 end do success = .false. end subroutine increment_box_coord @ %def increment_box_coord @ We parallelize [[VEGAS]] in simple forward manner. The hyper-cube is dissambled in to equidistant boxes in which we sample the integrand [[calls_per_box]] times. The workload of calculating those boxes is distributed along the worker. The number of dimensions which will be parallelised are $\lfloor \frac{D}{2} \rfloor$, such MPI Variables for [[vegas_integrate]]. We have to duplicate all buffers for [[MPI_Ireduce]], because we cannot use the same send or receive buffer. We temporarily store a (empty) grid, before communicating. <>= integer :: rank logical :: parallel_mode type(vegas_grid_t) :: grid @ MPI procedure-specific initialization. Allow for (external) veto on parallel mode. <>= parallel_mode = self%parallel_mode .and. self%is_parallelizable () if (parallel_mode) then call MPI_Comm_size (self%comm, n_size) call MPI_Comm_rank (self%comm, rank) else n_size = 1 rank = 0 end if @ Pre-sampling communication. We make a copy of the (actual) grid, which is unfilled when non-root. The actual grid is then broadcasted among the workers and inserted into the [[VEGAS]] object. <>= if (parallel_mode) then grid = self%get_grid () call grid%broadcast (self%comm) call self%set_grid (grid) @ Start index of the boxes for different ranks. If the random number generator is RngStream, we can advance the current stream in such a way, that we will getting matching numbers. Iff [[n_boxes]] is larger than 2, otherwise parallelization is useless. <>= do k = 1, rank call increment_box_coord (self%box(1:n_dim_par), box_success) if (.not. box_success) exit end do select type (rng) type is (rng_stream_t) call rng%advance_state (self%config%n_dim * self%config%calls_per_box& & * self%config%n_boxes**(self%config%n_dim - n_dim_par) * rank) end select end if @ Increment [[n_size]] times the box coordinates. <>= if (parallel_mode) then select type (rng) type is (rng_stream_t) call rng%advance_state (self%config%n_dim * self%config%calls_per_box& & * self%config%n_boxes**(self%config%n_dim - n_dim_par) * (n_size - 1)) end select end if @ Call to [[vegas_integrate_collect]]. <>= if (parallel_mode) then call vegas_integrate_collect () if (rank /= 0) cycle iteration end if @ Reduce (in an non-blocking fashion) all sampled information via [[MPI_SUM]] or [[MPI_MAX]]. <>= subroutine vegas_integrate_collect () integer :: j real(default) :: root_total_integral, root_total_sq_integral real(default) :: root_sum_abs_f_pos, root_max_abs_f_pos real(default) :: root_sum_abs_f_neg, root_max_abs_f_neg real(default), dimension(self%config%n_bins_max, self%config%n_dim) :: root_d type(MPI_Request), dimension(self%config%n_dim + 6) :: status root_d = 0._default root_sum_abs_f_pos = 0._default root_sum_abs_f_neg = 0._default root_max_abs_f_pos = 0._default root_sum_abs_f_neg = 0._default root_total_integral = 0._default root_total_sq_integral = 0._default call MPI_Ireduce (sum_abs_f_pos, root_sum_abs_f_pos, 1, MPI_DOUBLE_PRECISION,& & MPI_SUM, 0, self%comm, status(1)) call MPI_Ireduce (sum_abs_f_neg, root_sum_abs_f_neg, 1, MPI_DOUBLE_PRECISION,& & MPI_SUM, 0, self%comm, status(2)) call MPI_Ireduce (max_abs_f_pos, root_max_abs_f_pos, 1, MPI_DOUBLE_PRECISION,& & MPI_MAX, 0, self%comm, status(3)) call MPI_Ireduce (max_abs_f_neg, root_max_abs_f_neg, 1, MPI_DOUBLE_PRECISION,& & MPI_MAX, 0, self%comm, status(4)) call MPI_Ireduce (total_integral, root_total_integral, 1, MPI_DOUBLE_PRECISION,& & MPI_SUM, 0, self%comm, status(5)) call MPI_Ireduce (total_sq_integral, root_total_sq_integral, 1,& & MPI_DOUBLE_PRECISION, MPI_SUM, 0, self%comm, status(6)) do j = 1, self%config%n_dim call MPI_Ireduce (self%d(1:self%config%n_bins, j), root_d(1:self%config& &%n_bins, j), self%config%n_bins, MPI_DOUBLE_PRECISION, MPI_SUM, 0,& & self%comm, status(6 + j)) end do call MPI_Waitall (self%config%n_dim + 6, status, MPI_STATUSES_IGNORE) if (rank == 0) sum_abs_f_pos = root_sum_abs_f_pos if (rank == 0) sum_abs_f_neg = root_sum_abs_f_neg if (rank == 0) max_abs_f_pos = root_max_abs_f_pos if (rank == 0) max_abs_f_neg = root_max_abs_f_neg if (rank == 0) total_integral = root_total_integral if (rank == 0) total_sq_integral = root_total_sq_integral if (rank == 0) self%d = root_d end subroutine vegas_integrate_collect @ %def vegas_integrate_collect -@ +@ Obtain a random point inside the $n$-dimensional hypercube, transform onto the correct interval and calculate the bin volume. The additional factor [[n_bins]] is already applied to the [[jacobian]] (per dimension). <>= procedure, private :: random_point => vegas_random_point <>= module subroutine vegas_random_point (self, rng, x, bin_volume) class(vegas_t), intent(inout) :: self class(rng_t), intent(inout) :: rng real(default), dimension(self%config%n_dim), intent(out) :: x real(default), intent(out) :: bin_volume end subroutine vegas_random_point <>= module subroutine vegas_random_point (self, rng, x, bin_volume) class(vegas_t), intent(inout) :: self class(rng_t), intent(inout) :: rng real(default), dimension(self%config%n_dim), intent(out) :: x real(default), intent(out) :: bin_volume integer :: j real(default) :: r, y, z, bin_width bin_volume = 1. ndim: do j = 1, self%config%n_dim call rng%generate (r) z = ((self%box(j) - 1 + r) / self%config%n_boxes) * self%config%n_bins + 1 self%bin(j) = max (min (int (z), self%config%n_bins), 1) if (self%bin(j) == 1) then bin_width = self%grid%xi(2, j) y = (z - self%bin(j)) * bin_width else bin_width = self%grid%xi(self%bin(j) + 1, j) - self%grid%xi(self%bin(j), j) y = self%grid%xi(self%bin(j), j) + (z - self%bin(j)) * bin_width end if x(j) = self%grid%x_lower(j) + y * self%grid%delta_x(j) bin_volume = bin_volume * bin_width end do ndim end subroutine vegas_random_point @ %def vegas_random_point @ Obtain a random point inside the $n$-dimensional hyper-cube. We neglect stratification and generate the random point in the most simple way. Hence, we do not need to know in which box we are actually sampling. This is useful for only for event generation. <>= procedure, private :: simple_random_point => vegas_simple_random_point <>= module subroutine vegas_simple_random_point (self, rng, x, bin_volume) class(vegas_t), intent(inout) :: self class(rng_t), intent(inout) :: rng real(default), dimension(self%config%n_dim), intent(out) :: x real(default), intent(out) :: bin_volume end subroutine vegas_simple_random_point <>= module subroutine vegas_simple_random_point (self, rng, x, bin_volume) class(vegas_t), intent(inout) :: self class(rng_t), intent(inout) :: rng real(default), dimension(self%config%n_dim), intent(out) :: x real(default), intent(out) :: bin_volume integer :: j, k real(default) :: r, y, z, bin_width bin_volume = 1. ndim: do j = 1, self%config%n_dim call rng%generate (r) z = r * self%config%n_bins + 1 k = max (min (int (z), self%config%n_bins), 1) if (k == 1) then bin_width = self%grid%xi(2, j) y = (z - 1) * bin_width else bin_width = self%grid%xi(k + 1, j) - self%grid%xi(k, j) y = self%grid%xi(k, j) + (z - k) * bin_width end if x(j) = self%grid%x_lower(j) + y * self%grid%delta_x(j) bin_volume = bin_volume * bin_width end do ndim end subroutine vegas_simple_random_point @ %def vegas_simple_random_point @ <>= procedure, private :: accumulate_distribution => vegas_accumulate_distribution <>= module subroutine vegas_accumulate_distribution (self, y) class(vegas_t), intent(inout) :: self real(default), intent(in) :: y end subroutine vegas_accumulate_distribution <>= module subroutine vegas_accumulate_distribution (self, y) class(vegas_t), intent(inout) :: self real(default), intent(in) :: y integer :: j do j = 1, self%config%n_dim self%d(self%bin(j), j) = self%d(self%bin(j), j) + y end do end subroutine vegas_accumulate_distribution @ %def vegas_accumulate_distribution @ Generate weighted random event. The weight given by the overall jacobian \begin{equation} \Delta_{\text{jac}} = \prod_{j=1}^{d} \left( x_j^+ - x_j^- \right) \frac{N_{\text{bins}}^d}{N_{\text{calls}}} \end{equation} includes the overall non-changing factors $\frac{1}{N_{\text{calls}}}$-factor (divisions are expensive) and $N_{\text{bins}}^{d}$, the latter combined with [[bin_volume]] gives rise to the probability, see [[vegas_init_grid]] for details. We have to factor out $N_{\text{calls}}$ to retrieve the correct weight. <>= procedure :: generate_weighted => vegas_generate_weighted_event <>= module subroutine vegas_generate_weighted_event (self, func, rng, x) class(vegas_t), intent(inout) :: self class(vegas_func_t), intent(inout) :: func class(rng_t), intent(inout) :: rng real(default), dimension(self%config%n_dim), intent(inout) :: x end subroutine vegas_generate_weighted_event <>= module subroutine vegas_generate_weighted_event (self, func, rng, x) class(vegas_t), intent(inout) :: self class(vegas_func_t), intent(inout) :: func class(rng_t), intent(inout) :: rng real(default), dimension(self%config%n_dim), intent(inout) :: x real(default) :: bin_volume call self%simple_random_point (rng, x, bin_volume) ! Cancel n_calls from jacobian with n_calls self%result%evt_weight = self%config%n_calls * self%jacobian * bin_volume & & * func%evaluate (x) end subroutine vegas_generate_weighted_event @ %def vegas_generate_weighted_event @ Generate random event. We accept on the rate \begin{equation} \frac{|f(x)|}{\underset{x}{\max} |f(x)|}. \end{equation} We keep separate maximum weights for positive and negative weights, and use them, accordingly. In the case of unweighted event generation, if the current weight exceeds the the maximum weight, we update the maximum, accordingly. <>= procedure, public :: generate_unweighted=> vegas_generate_unweighted_event <>= module subroutine vegas_generate_unweighted_event (self, func, rng, x) class(vegas_t), intent(inout) :: self class(vegas_func_t), intent(inout) :: func class(rng_t), intent(inout) :: rng real(default), dimension(self%config%n_dim), intent(out) :: x end subroutine vegas_generate_unweighted_event <>= module subroutine vegas_generate_unweighted_event (self, func, rng, x) class(vegas_t), intent(inout) :: self class(vegas_func_t), intent(inout) :: func class(rng_t), intent(inout) :: rng real(default), dimension(self%config%n_dim), intent(out) :: x real(default) :: bin_volume - real(default) :: max_abs_f real(default) :: r associate (result => self%result) generate: do call self%generate_weighted (func, rng, x) - max_abs_f = merge (result%max_abs_f_pos, result%max_abs_f_neg, & - & result%evt_weight > 0.) - if (result%evt_weight > max_abs_f) then + if (abs(result%evt_weight) > result%max_abs_f) then result%evt_weight_excess = & - & result%evt_weight / max_abs_f - 1._default + & abs(result%evt_weight) / result%max_abs_f - 1._default exit generate end if call rng%generate (r) ! Do not use division, because max_abs_f could be zero. - if (max_abs_f * r <= abs(result%evt_weight)) then + if (result%max_abs_f * r <= abs(result%evt_weight)) then exit generate end if end do generate end associate end subroutine vegas_generate_unweighted_event @ %def vegas_random_event \section{I/0 operation} \label{sec:i0-operation} @ Write grid to file. We use the original VAMP formater. <>= character(len=*), parameter, private :: & descr_fmt = "(1X,A)", & integer_fmt = "(1X,A18,1X,I15)", & integer_array_fmt = "(1X,I18,1X,I15)", & logical_fmt = "(1X,A18,1X,L1)", & double_fmt = "(1X,A18,1X,E24.16E4)", & double_array_fmt = "(1X,I18,1X,E24.16E4)", & double_array_pac_fmt = "(1X,I18,1X,E16.8E4)", & double_array2_fmt = "(1X,2(1X,I8),1X,E24.16E4)", & double_array2_pac_fmt = "(1X,2(1X,I8),1X,E16.8E4)" @ %def descr_fmt integer_fmt integer_array_fmt logical_fmt @ %def double_fmt double_array_fmt double_array2_fmt <>= procedure, public :: write_grid => vegas_write_grid <>= module subroutine vegas_write_grid (self, unit) class(vegas_t), intent(in) :: self integer, intent(in), optional :: unit end subroutine vegas_write_grid <>= module subroutine vegas_write_grid (self, unit) class(vegas_t), intent(in) :: self integer, intent(in), optional :: unit integer :: u integer :: i, j u = given_output_unit (unit) write (u, descr_fmt) "begin type(vegas_t)" write (u, integer_fmt) "n_dim =", self%config%n_dim write (u, integer_fmt) "n_bins_max =", self%config%n_bins_max write (u, double_fmt) "alpha =", self%config%alpha write (u, integer_fmt) "iterations =", self%config%iterations write (u, integer_fmt) "mode =", self%config%mode write (u, integer_fmt) "calls_per_box =", self%config%calls_per_box write (u, integer_fmt) "n_calls =", self%config%n_calls write (u, integer_fmt) "n_calls_min =", self%config%n_calls_min write (u, integer_fmt) "n_boxes =", self%config%n_boxes write (u, integer_fmt) "n_bins =", self%config%n_bins write (u, integer_fmt) "it_start =", self%result%it_start write (u, integer_fmt) "it_num =", self%result%it_num write (u, integer_fmt) "samples =", self%result%samples write (u, double_fmt) "sum_int_wgtd =", self%result%sum_int_wgtd write (u, double_fmt) "sum_wgts =", self%result%sum_wgts write (u, double_fmt) "sum_chi =", self%result%sum_chi write (u, double_fmt) "chi2 =", self%result%chi2 write (u, double_fmt) "efficiency =", self%result%efficiency write (u, double_fmt) "efficiency =", self%result%efficiency_pos write (u, double_fmt) "efficiency =", self%result%efficiency_neg write (u, double_fmt) "max_abs_f =", self%result%max_abs_f write (u, double_fmt) "max_abs_f_pos =", self%result%max_abs_f_pos write (u, double_fmt) "max_abs_f_neg =", self%result%max_abs_f_neg write (u, double_fmt) "result =", self%result%result write (u, double_fmt) "std =", self%result%std write (u, double_fmt) "hypercube_volume =", self%hypercube_volume write (u, double_fmt) "jacobian =", self%jacobian write (u, descr_fmt) "begin x_lower" do j = 1, self%config%n_dim write (u, double_array_fmt) j, self%grid%x_lower(j) end do write (u, descr_fmt) "end x_lower" write (u, descr_fmt) "begin x_upper" do j = 1, self%config%n_dim write (u, double_array_fmt) j, self%grid%x_upper(j) end do write (u, descr_fmt) "end x_upper" write (u, descr_fmt) "begin delta_x" do j = 1, self%config%n_dim write (u, double_array_fmt) j, self%grid%delta_x(j) end do write (u, descr_fmt) "end delta_x" write (u, integer_fmt) "n_bins =", self%config%n_bins write (u, descr_fmt) "begin bin" do j = 1, self%config%n_dim write (u, integer_array_fmt) j, self%bin(j) end do write (u, descr_fmt) "end n_bin" write (u, integer_fmt) "n_boxes =", self%config%n_boxes write (u, descr_fmt) "begin box" do j = 1, self%config%n_dim write (u, integer_array_fmt) j, self%box(j) end do write (u, descr_fmt) "end box" write (u, descr_fmt) "begin d" do j = 1, self%config%n_dim do i = 1, self%config%n_bins_max write (u, double_array2_fmt) i, j, self%d(i, j) end do end do write (u, descr_fmt) "end d" write (u, descr_fmt) "begin xi" do j = 1, self%config%n_dim do i = 1, self%config%n_bins_max + 1 write (u, double_array2_fmt) i, j, self%grid%xi(i, j) end do end do write (u, descr_fmt) "end xi" write (u, descr_fmt) "end type(vegas_t)" end subroutine vegas_write_grid @ %def vegas_write_grid @ Read grid configuration from file. <>= procedure, public :: read_grid => vegas_read_grid <>= module subroutine vegas_read_grid (self, unit) class(vegas_t), intent(out) :: self integer, intent(in) :: unit end subroutine vegas_read_grid <>= module subroutine vegas_read_grid (self, unit) class(vegas_t), intent(out) :: self integer, intent(in) :: unit integer :: i, j character(len=80) :: buffer integer :: ibuffer, jbuffer read (unit, descr_fmt) buffer read (unit, integer_fmt) buffer, ibuffer read (unit, integer_fmt) buffer, jbuffer select type(self) type is (vegas_t) self = vegas_t (n_dim = ibuffer, n_bins_max = jbuffer) end select read (unit, double_fmt) buffer, self%config%alpha read (unit, integer_fmt) buffer, self%config%iterations read (unit, integer_fmt) buffer, self%config%mode read (unit, integer_fmt) buffer, self%config%calls_per_box read (unit, integer_fmt) buffer, self%config%n_calls read (unit, integer_fmt) buffer, self%config%n_calls_min read (unit, integer_fmt) buffer, self%config%n_boxes read (unit, integer_fmt) buffer, self%config%n_bins self%grid%n_bins = self%config%n_bins read (unit, integer_fmt) buffer, self%result%it_start read (unit, integer_fmt) buffer, self%result%it_num read (unit, integer_fmt) buffer, self%result%samples read (unit, double_fmt) buffer, self%result%sum_int_wgtd read (unit, double_fmt) buffer, self%result%sum_wgts read (unit, double_fmt) buffer, self%result%sum_chi read (unit, double_fmt) buffer, self%result%chi2 read (unit, double_fmt) buffer, self%result%efficiency read (unit, double_fmt) buffer, self%result%efficiency_pos read (unit, double_fmt) buffer, self%result%efficiency_neg read (unit, double_fmt) buffer, self%result%max_abs_f read (unit, double_fmt) buffer, self%result%max_abs_f_pos read (unit, double_fmt) buffer, self%result%max_abs_f_neg read (unit, double_fmt) buffer, self%result%result read (unit, double_fmt) buffer, self%result%std read (unit, double_fmt) buffer, self%hypercube_volume read (unit, double_fmt) buffer, self%jacobian read (unit, descr_fmt) buffer do j = 1, self%config%n_dim read (unit, double_array_fmt) jbuffer, self%grid%x_lower(j) end do read (unit, descr_fmt) buffer read (unit, descr_fmt) buffer do j = 1, self%config%n_dim read (unit, double_array_fmt) jbuffer, self%grid%x_upper(j) end do read (unit, descr_fmt) buffer read (unit, descr_fmt) buffer do j = 1, self%config%n_dim read (unit, double_array_fmt) jbuffer, self%grid%delta_x(j) end do read (unit, descr_fmt) buffer read (unit, integer_fmt) buffer, self%config%n_bins read (unit, descr_fmt) buffer do j = 1, self%config%n_dim read (unit, integer_array_fmt) jbuffer, self%bin(j) end do read (unit, descr_fmt) buffer read (unit, integer_fmt) buffer, self%config%n_boxes read (unit, descr_fmt) buffer do j = 1, self%config%n_dim read (unit, integer_array_fmt) jbuffer, self%box(j) end do read (unit, descr_fmt) buffer read (unit, descr_fmt) buffer do j = 1, self%config%n_dim do i = 1, self%config%n_bins_max read (unit, double_array2_fmt) ibuffer, jbuffer, self%d(i, j) end do end do read (unit, descr_fmt) buffer read (unit, descr_fmt) buffer do j = 1, self%config%n_dim do i = 1, self%config%n_bins_max + 1 read (unit, double_array2_fmt) ibuffer, jbuffer, self%grid%xi(i, j) end do end do read (unit, descr_fmt) buffer read (unit, descr_fmt) buffer end subroutine vegas_read_grid @ %def vegas_read_grid Read and write a grid from an unformatted file. <>= procedure :: write_binary_grid => vegas_write_binary_grid procedure :: read_binary_grid => vegas_read_binary_grid <>= module subroutine vegas_write_binary_grid (self, unit) class(vegas_t), intent(in) :: self integer, intent(in) :: unit end subroutine vegas_write_binary_grid module subroutine vegas_read_binary_grid (self, unit) class(vegas_t), intent(out) :: self integer, intent(in) :: unit end subroutine vegas_read_binary_grid <>= module subroutine vegas_write_binary_grid (self, unit) class(vegas_t), intent(in) :: self integer, intent(in) :: unit integer :: i, j write (unit) self%config%n_dim write (unit) self%config%n_bins_max write (unit) self%config%alpha write (unit) self%config%iterations write (unit) self%config%mode write (unit) self%config%calls_per_box write (unit) self%config%n_calls write (unit) self%config%n_calls_min write (unit) self%config%n_boxes write (unit) self%config%n_bins write (unit) self%result%it_start write (unit) self%result%it_num write (unit) self%result%samples write (unit) self%result%sum_int_wgtd write (unit) self%result%sum_wgts write (unit) self%result%sum_chi write (unit) self%result%chi2 write (unit) self%result%efficiency write (unit) self%result%efficiency_pos write (unit) self%result%efficiency_neg write (unit) self%result%max_abs_f write (unit) self%result%max_abs_f_pos write (unit) self%result%max_abs_f_neg write (unit) self%result%result write (unit) self%result%std write (unit) self%hypercube_volume write (unit) self%jacobian do j = 1, self%config%n_dim write (unit) j, self%grid%x_lower(j) end do do j = 1, self%config%n_dim write (unit) j, self%grid%x_upper(j) end do do j = 1, self%config%n_dim write (unit) j, self%grid%delta_x(j) end do write (unit) self%config%n_bins do j = 1, self%config%n_dim write (unit) j, self%bin(j) end do write (unit) self%config%n_boxes do j = 1, self%config%n_dim write (unit) j, self%box(j) end do do j = 1, self%config%n_dim do i = 1, self%config%n_bins_max write (unit) i, j, self%d(i, j) end do end do do j = 1, self%config%n_dim do i = 1, self%config%n_bins_max + 1 write (unit) i, j, self%grid%xi(i, j) end do end do end subroutine vegas_write_binary_grid module subroutine vegas_read_binary_grid (self, unit) class(vegas_t), intent(out) :: self integer, intent(in) :: unit integer :: i, j integer :: ibuffer, jbuffer read (unit) ibuffer read (unit) jbuffer select type(self) type is (vegas_t) self = vegas_t (n_dim = ibuffer, n_bins_max = jbuffer) end select read (unit) self%config%alpha read (unit) self%config%iterations read (unit) self%config%mode read (unit) self%config%calls_per_box read (unit) self%config%n_calls read (unit) self%config%n_calls_min read (unit) self%config%n_boxes read (unit) self%config%n_bins self%grid%n_bins = self%config%n_bins read (unit) self%result%it_start read (unit) self%result%it_num read (unit) self%result%samples read (unit) self%result%sum_int_wgtd read (unit) self%result%sum_wgts read (unit) self%result%sum_chi read (unit) self%result%chi2 read (unit) self%result%efficiency read (unit) self%result%efficiency_pos read (unit) self%result%efficiency_neg read (unit) self%result%max_abs_f read (unit) self%result%max_abs_f_pos read (unit) self%result%max_abs_f_neg read (unit) self%result%result read (unit) self%result%std read (unit) self%hypercube_volume read (unit) self%jacobian do j = 1, self%config%n_dim read (unit) jbuffer, self%grid%x_lower(j) end do do j = 1, self%config%n_dim read (unit) jbuffer, self%grid%x_upper(j) end do do j = 1, self%config%n_dim read (unit) jbuffer, self%grid%delta_x(j) end do read (unit) self%config%n_bins do j = 1, self%config%n_dim read (unit) jbuffer, self%bin(j) end do read (unit) self%config%n_boxes do j = 1, self%config%n_dim read (unit) jbuffer, self%box(j) end do do j = 1, self%config%n_dim do i = 1, self%config%n_bins_max read (unit) ibuffer, jbuffer, self%d(i, j) end do end do do j = 1, self%config%n_dim do i = 1, self%config%n_bins_max + 1 read (unit) ibuffer, jbuffer, self%grid%xi(i, j) end do end do end subroutine vegas_read_binary_grid @ %def vegas_write_binary_grid, vegas_read_binary_grid \section{Unit tests} \label{sec:unit-tests} Test module, followed by the corresponding implementation module. <<[[vegas_ut.f90]]>>= <> module vegas_ut use unit_tests use vegas_uti <> <> contains <> end module vegas_ut @ %def vegas_ut @ <<[[vegas_uti.f90]]>>= <> module vegas_uti <> use io_units use constants, only: pi use format_defs, only: FMT_10, FMT_12 use rng_base use rng_stream use vegas <> <> <> contains <> end module vegas_uti @ %def vegas_uti @ API: driver for the unit tests below. <>= public :: vegas_test <>= subroutine vegas_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine vegas_test @ %def vegas_test @ \subsubsection{Test function} \label{sec:test-function} We use the example from the Monte Carlo Examples of the GSL library \begin{equation} I = \int_{-pi}^{+pi} {dk_x/(2 pi)} \int_{-pi}^{+pi} {dk_y/(2 pi)} \int_{-pi}^{+pi} {dk_z/(2 pi)} 1 / (1 - cos(k_x)cos(k_y)cos(k_z)). \end{equation} The integral is reduced to region (0,0,0) $\rightarrow$ ($\pi$, $\pi$, $\pi$) and multiplied by 8. <>= type, extends (vegas_func_t) :: vegas_test_func_t ! contains <> end type vegas_test_func_t @ %def vegas_test_func_t @ Evaluate the integrand. <>= procedure, public :: evaluate => vegas_test_func_evaluate <>= real(default) function vegas_test_func_evaluate (self, x) result (f) class(vegas_test_func_t), intent(inout) :: self real(default), dimension(:), intent(in) :: x f = 1.0 / (pi**3) f = f / ( 1.0 - cos (x(1)) * cos (x(2)) * cos (x(3))) end function vegas_test_func_evaluate @ %def vegas_test_func_evaluate @ The second test function is the normalised n-dim.\@ gaussian distribution. <>= type, extends (vegas_func_t) :: vegas_gaussian_test_func_t ! contains <> end type vegas_gaussian_test_func_t @ %def vegas_gaussian_test_func_t @ Evaluate the integrand. <>= procedure, public :: evaluate => vegas_gaussian_evaluate <>= real(default) function vegas_gaussian_evaluate (self, x) result (f) class(vegas_gaussian_test_func_t), intent(inout) :: self real(default), dimension(:), intent(in) :: x real(default), parameter :: inv_sqrt_pi = 1._default / sqrt(pi) f = inv_sqrt_pi**size (x) f = f * exp (- dot_product(x, x)) end function vegas_gaussian_evaluate @ %def vegas_gaussian_evaluate @ The third test function is a three-dimensional polynomial function which factories. The function is defined in such a way that the integral in the unit range is normalised to zero. \begin{equation} f(x) = - \frac{8}{3} (x + 1)*(y-1)*z \end{equation} <>= type, extends (vegas_func_t) :: vegas_polynomial_func_t ! contains <> end type vegas_polynomial_func_t @ %def vegas_polynomial_func_t <>= procedure, public :: evaluate => vegas_polynomial_evaluate <>= real(default) function vegas_polynomial_evaluate (self, x) result (f) class(vegas_polynomial_func_t), intent(inout) :: self real(default), dimension(:), intent(in) :: x f = - 8. / 3. * (x(1) + 1.) * (x(2) - 1.) * x(3) end function vegas_polynomial_evaluate @ %def vegas_polynomial_evaluate @ \subsubsection{MC Integrator check} \label{sec:mc-integrator-check} Initialise the VEGAS MC integrator and call to [[vegas_init_grid]] for the initialisation of the grid. <>= call test (vegas_1, "vegas_1", "VEGAS initialisation and& & grid preparation", u, results) <>= public :: vegas_1 <>= subroutine vegas_1 (u) integer, intent(in) :: u type(vegas_t) :: mc_integrator class(rng_t), allocatable :: rng class(vegas_func_t), allocatable :: func real(default), dimension(3), parameter :: x_lower = 0., & x_upper = pi real(default) :: result, abserr write (u, "(A)") "* Test output: vegas_1" write (u, "(A)") "* Purpose: initialise the VEGAS MC integrator and the grid" write (u, "(A)") write (u, "(A)") "* Initialise random number generator (default seed)" write (u, "(A)") allocate (rng_stream_t :: rng) call rng%init () call rng%write (u) write (u, "(A)") write (u, "(A)") "* Initialise MC integrator with n_dim = 3" write (u, "(A)") allocate (vegas_test_func_t :: func) mc_integrator = vegas_t (3) write (u, "(A)") write (u, "(A)") "* Initialise grid with n_calls = 10000" write (u, "(A)") call mc_integrator%set_limits (x_lower, x_upper) call mc_integrator%set_calls (10000) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 10000 (Adaptation)" write (u, "(A)") call mc_integrator%integrate (func, rng, 3, result=result, abserr=abserr) write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ")") "Result: ", result, " +/- ", abserr write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 2000 (Precision)" write (u, "(A)") call mc_integrator%set_calls (2000) call mc_integrator%integrate (func, rng, 3, result=result, abserr=abserr) write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ")") "Result: ", result, " +/- ", abserr write (u, "(A)") write (u, "(A)") "* Cleanup" call mc_integrator%final () call rng%final () deallocate (rng) end subroutine vegas_1 @ %def vegas_1 @ \subsubsection{Configuration and result check} \label{sec:conf-result-check} Initialise the MC integrator. Get and write the config object, also the (empty) result object. <>= call test (vegas_2, "vegas_2", "VEGAS configuration and result object", u, results) <>= public :: vegas_2 <>= subroutine vegas_2 (u) integer, intent(in) :: u type(vegas_t) :: mc_integrator type(vegas_config_t) :: mc_integrator_config type(vegas_result_t) :: mc_integrator_result write (u, "(A)") "* Test output: vegas_2" write (u, "(A)") "* Purpose: use transparent containers for& & configuration and result." write (u, "(A)") write (u, "(A)") write (u, "(A)") "* Initialise MC integrator with n_dim = 10" write (u, "(A)") mc_integrator = vegas_t (10) write (u, "(A)") write (u, "(A)") "* Initialise grid with n_calls = 10000 (Importance Sampling)" write (u, "(A)") call mc_integrator%set_calls (10000) write (u, "(A)") write (u, "(A)") "* Get VEGAS config object and write out" write (u, "(A)") call mc_integrator%get_config (mc_integrator_config) call mc_integrator_config%write (u) write (u, "(A)") write (u, "(A)") "* Get VEGAS empty result object and write out" write (u, "(A)") mc_integrator_result = mc_integrator%get_result () call mc_integrator_result%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mc_integrator%final () end subroutine vegas_2 @ %def vegas_2 @ \subsubsection{Grid check} \label{sec:conf-result-check} Initialise the MC integrator. Get and write the config object. Integrate the gaussian distribution. Get and write the result object. Before and after integration get the grid object and output both. Repeat with different number of dimensions. <>= call test (vegas_3, "vegas_3", "VEGAS integration of multi-dimensional gaussian", u, results) <>= public :: vegas_3 <>= subroutine vegas_3 (u) integer, intent(in) :: u type(vegas_t) :: mc_integrator class(rng_t), allocatable :: rng class(vegas_func_t), allocatable :: func real(default), dimension(3), parameter :: x_lower_3 = -10._default, & x_upper_3 = 10._default type(vegas_config_t) :: mc_integrator_config type(vegas_grid_t) :: mc_integrator_grid type(vegas_result_t) :: mc_integrator_result real(default) :: result, abserr write (u, "(A)") "* Test output: vegas_3" write (u, "(A)") "* Purpose: Integrate gaussian distribution." write (u, "(A)") allocate (rng_stream_t :: rng) call rng%init () call rng%write (u) write (u, "(A)") write (u, "(A)") "* Initialise MC integrator with n_dim = 3" write (u, "(A)") allocate (vegas_gaussian_test_func_t :: func) mc_integrator = vegas_t (3) write (u, "(A)") write (u, "(A)") "* Initialise grid with n_calls = 10000" write (u, "(A)") call mc_integrator%set_limits (x_lower_3, x_upper_3) call mc_integrator%set_calls (10000) write (u, "(A)") write (u, "(A)") "* Get VEGAS config object and write out" write (u, "(A)") call mc_integrator%get_config (mc_integrator_config) call mc_integrator_config%write (u) write (u, "(A)") write (u, "(A)") "* Get VEGAS grid object and write out" write (u, "(A)") mc_integrator_grid = mc_integrator%get_grid () call mc_integrator_grid%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 20000 (Adaptation)" write (u, "(A)") call mc_integrator%integrate (func, rng, 3, result=result, abserr=abserr) write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ")") "Result: ", result, " +/- ", abserr write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 2000 (Precision)" write (u, "(A)") call mc_integrator%set_calls (2000) call mc_integrator%get_config (mc_integrator_config) call mc_integrator_config%write (u) write (u, "(A)") call mc_integrator%integrate (func, rng, 3, result=result, abserr=abserr) write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ")") "Result: ", result, " +/- ", abserr write (u, "(A)") write (u, "(A)") "* Get VEGAS result object and write out" write (u, "(A)") mc_integrator_result = mc_integrator%get_result () call mc_integrator_result%write (u) write (u, "(A)") write (u, "(A)") "* Get VEGAS grid object and write out" write (u, "(A)") mc_integrator_grid = mc_integrator%get_grid () call mc_integrator_grid%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call mc_integrator%final () end subroutine vegas_3 @ %def vegas_3 \subsubsection{Three-dimensional integration with polynomial function} \label{sec:conf-result-check} Initialise the MC integrator. Get and write the config object. Integrate the factorisable polynomial function. Get and write the result object. Repeat with different number of dimensions. <>= call test (vegas_4, "vegas_4", "VEGAS integration of three& &-dimensional factorisable polynomial function", u, results) <>= public :: vegas_4 <>= subroutine vegas_4 (u) integer, intent(in) :: u type(vegas_t) :: mc_integrator class(rng_t), allocatable :: rng class(vegas_func_t), allocatable :: func real(default), dimension(3), parameter :: x_lower_3 = 0._default, & x_upper_3 = 1._default type(vegas_config_t) :: mc_integrator_config type(vegas_result_t) :: mc_integrator_result real(default) :: result, abserr write (u, "(A)") "* Test output: vegas_4" write (u, "(A)") "* Purpose: Integrate gaussian distribution." write (u, "(A)") allocate (rng_stream_t :: rng) call rng%init () call rng%write (u) write (u, "(A)") write (u, "(A)") "* Initialise MC integrator with n_dim = 3" write (u, "(A)") allocate (vegas_polynomial_func_t :: func) mc_integrator = vegas_t (3) write (u, "(A)") write (u, "(A)") "* Initialise grid with n_calls = 2000" write (u, "(A)") call mc_integrator%set_limits (x_lower_3, x_upper_3) call mc_integrator%set_calls (2000) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 2000 (Adaptation)" write (u, "(A)") call mc_integrator%integrate (func, rng, 3, result=result, abserr=abserr) call mc_integrator%get_config (mc_integrator_config) call mc_integrator_config%write (u) write (u, "(A)") write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ")") "Result: ", result, " +/- ", abserr write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 20000 (Precision)" write (u, "(A)") call mc_integrator%set_calls (20000) call mc_integrator%integrate (func, rng, 3, result=result, abserr=abserr) call mc_integrator%get_config (mc_integrator_config) call mc_integrator_config%write (u) write (u, "(A)") write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ")") "Result: ", result, " +/- ", abserr write (u, "(A)") write (u, "(A)") "* Cleanup" call mc_integrator%final () end subroutine vegas_4 @ %def vegas_4 @ \subsubsection{Event generation} Initialise the MC integrator. Integrate the gaussian distribution. Get and write the result object. Finally, generate events in accordance to the adapted grid and print them out. <>= call test (vegas_5, "vegas_5", "VEGAS integration and event& & generation of multi-dimensional gaussian", u, results) <>= public :: vegas_5 <>= subroutine vegas_5 (u) integer, intent(in) :: u type(vegas_t) :: mc_integrator class(rng_t), allocatable :: rng class(vegas_func_t), allocatable :: func real(default), dimension(1), parameter :: x_lower_1 = -10._default, & x_upper_1 = 10._default type(vegas_config_t) :: mc_integrator_config type(vegas_result_t) :: mc_integrator_result integer :: i, u_event real(default), dimension(1) :: event, mean, delta, M2 real(default) :: result, abserr write (u, "(A)") "* Test output: vegas_5" write (u, "(A)") "* Purpose: Integrate gaussian distribution." write (u, "(A)") allocate (rng_stream_t :: rng) call rng%init () call rng%write (u) write (u, "(A)") write (u, "(A)") "* Initialise MC integrator with n_dim = 1" write (u, "(A)") allocate (vegas_gaussian_test_func_t :: func) mc_integrator = vegas_t (1) write (u, "(A)") write (u, "(A)") "* Initialise grid with n_calls = 20000" write (u, "(A)") call mc_integrator%set_limits (x_lower_1, x_upper_1) call mc_integrator%set_calls (20000) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 (Adaptation)" write (u, "(A)") call mc_integrator%integrate (func, rng, 3, verbose=.true., result=result, abserr=abserr) call mc_integrator%get_config (mc_integrator_config) call mc_integrator_config%write (u) write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ")") & & "Result: ", result, " +/- ", abserr write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 2000 (Precision)" write (u, "(A)") call mc_integrator%set_calls (2000) call mc_integrator%integrate (func, rng, 3, verbose=.true., result=result, abserr=abserr) call mc_integrator%get_config (mc_integrator_config) call mc_integrator_config%write (u) write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ")") & & "Result: ", result, " +/- ", abserr write (u, "(A)") write (u, "(A)") "* Generate 10000 events based on the adaptation and& & calculate mean and variance" write (u, "(A)") mean = 0._default M2 = 0._default do i = 1, 10000 call mc_integrator%generate_unweighted (func, rng, event) delta = event - mean mean = mean + delta / i M2 = M2 + delta * (event - mean) end do write (u, "(2X,A)") "Result:" write (u, "(4X,A," // FMT_12 //")") & & "mean = ", mean write (u, "(4X,A," // FMT_12 //")") & & "(sample) std. dev. = ", sqrt (M2 / (9999)) write (u, "(A)") write (u, "(A)") "* Cleanup" call mc_integrator%final () end subroutine vegas_5 @ %def vegas_5 @ \subsubsection{Grid I/O} \label{sec:grid-io} Initialise the MC integrator. Get and write the config object. Integrate the factorisable polynomial function. Get and write the result object. Write grid to file and start with fresh grid. <>= call test (vegas_6, "vegas_6", "VEGAS integrate and write grid, & & read grid and continue", u, results) <>= public :: vegas_6 <>= subroutine vegas_6 (u) integer, intent(in) :: u type(vegas_t) :: mc_integrator class(rng_t), allocatable :: rng class(vegas_func_t), allocatable :: func real(default), dimension(3), parameter :: x_lower_3 = 0._default, & x_upper_3 = 1._default type(vegas_config_t) :: mc_integrator_config type(vegas_result_t) :: mc_integrator_result real(default) :: result, abserr integer :: unit write (u, "(A)") "* Test output: vegas_6" write (u, "(A)") "* Purpose: Write and read grid, and continue." write (u, "(A)") allocate (rng_stream_t :: rng) call rng%init () call rng%write (u) write (u, "(A)") write (u, "(A)") "* Initialise MC integrator with n_dim = 3" write (u, "(A)") allocate (vegas_polynomial_func_t :: func) mc_integrator = vegas_t (3) write (u, "(A)") write (u, "(A)") "* Initialise grid with n_calls = 2000" write (u, "(A)") call mc_integrator%set_limits (x_lower_3, x_upper_3) call mc_integrator%set_calls (2000) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 2000 (Adaptation)" write (u, "(A)") call mc_integrator%integrate (func, rng, 3, result=result, abserr=abserr) call mc_integrator%get_config (mc_integrator_config) call mc_integrator_config%write (u) write (u, "(A)") write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ")") "Result: ", result, " +/- ", abserr write (u, "(A)") write (u, "(A)") "* Write grid to file vegas_io.grid" write (u, "(A)") unit = free_unit () open (unit, file = "vegas_io.grid", & action = "write", status = "replace") call mc_integrator%write_grid (unit) close (unit) write (u, "(A)") write (u, "(A)") "* Read grid from file vegas_io.grid" write (u, "(A)") call mc_integrator%final () open (unit, file = "vegas_io.grid", & action = "read", status = "old") call mc_integrator%read_grid (unit) close (unit) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 20000 (Precision)" write (u, "(A)") call mc_integrator%set_calls (20000) call mc_integrator%integrate (func, rng, 3, result=result, abserr=abserr) call mc_integrator%get_config (mc_integrator_config) call mc_integrator_config%write (u) write (u, "(A)") write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ")") "Result: ", result, " +/- ", abserr write (u, "(A)") write (u, "(A)") "* Cleanup" call mc_integrator%final () end subroutine vegas_6 @ %def vegas_6 @ \subsubsection{Numeric stability} \label{sec:numeric-stability} We wrap a previous testing function to produce a single [[NaN]]. <>= type, extends (vegas_test_func_t) :: vegas_nan_test_func_t private logical :: evaluate_to_nan = .true. contains <> end type vegas_nan_test_func_t @ %def vegas_nan_test_func_t @ Evaluate the integrand. <>= procedure, public :: evaluate => vegas_nan_test_func_evaluate <>= real(default) function vegas_nan_test_func_evaluate (self, x) result (f) use, intrinsic :: ieee_arithmetic, only: ieee_value, ieee_quiet_nan class(vegas_nan_test_func_t), intent(inout) :: self real(default), dimension(:), intent(in) :: x if (self%evaluate_to_nan) then f = ieee_value(1.0_default, ieee_quiet_nan) self%evaluate_to_nan = .false. else f = self%vegas_test_func_t%evaluate (x) end if end function vegas_nan_test_func_evaluate @ %def vegas_test_func_evaluate Initialise the VEGAS MC integrator. Run a integration pass and insert a single [[NaN]] that leads to a [[NaN]] result. However, the integration grid will be fine. Proceed with a second pass, and get the correct result. <>= !!! Disabled for the moment as NAGFOR stops execution on NaNs as intended ! call test (vegas_7, "vegas_7", "VEGAS NaN stability test", u, results) <>= public :: vegas_7 <>= subroutine vegas_7 (u) integer, intent(in) :: u type(vegas_t) :: mc_integrator class(rng_t), allocatable :: rng class(vegas_func_t), allocatable :: func real(default), dimension(3), parameter :: x_lower = 0., & x_upper = pi real(default) :: result, abserr write (u, "(A)") "* Test output: vegas_7" write (u, "(A)") "* Purpose: initialise the VEGAS MC integrator and the grid" write (u, "(A)") write (u, "(A)") "* Initialise random number generator (default seed)" write (u, "(A)") allocate (rng_stream_t :: rng) call rng%init () call rng%write (u) write (u, "(A)") write (u, "(A)") "* Initialise MC integrator with n_dim = 3" write (u, "(A)") allocate (vegas_nan_test_func_t :: func) mc_integrator = vegas_t (3) write (u, "(A)") write (u, "(A)") "* Initialise grid with n_calls = 10000" write (u, "(A)") call mc_integrator%set_limits (x_lower, x_upper) call mc_integrator%set_calls (10000) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 10000 (Adaptation)" write (u, "(A)") call mc_integrator%integrate (func, rng, 3, result=result, abserr=abserr) write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ")") "Result: ", result, " +/- ", abserr write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 2000 (Precision)" write (u, "(A)") call mc_integrator%set_calls (2000) call mc_integrator%integrate (func, rng, 3, result=result, abserr=abserr) write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ")") "Result: ", result, " +/- ", abserr write (u, "(A)") write (u, "(A)") "* Cleanup" call mc_integrator%final () call rng%final () deallocate (rng) end subroutine vegas_7 @ %def vegas_7 \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{VAMP2} \label{sec:vamp2} We concentrate all configuration and run-time data in a derived-type, such that, [[mci_t]] can spwan each time a distinctive MCI VEGAS integrator object. <<[[vamp2.f90]]>>= <> module vamp2 <> use diagnostics use rng_base use vegas <> <> <> <> <> <> interface <> end interface contains <> end module vamp2 @ %def vamp2 @ <<[[vamp2_sub.f90]]>>= <> submodule (vamp2) vamp2_s use io_units use format_utils, only: pac_fmt use format_utils, only: write_separator, write_indent use format_defs, only: FMT_17 use iterator use rng_stream, only: rng_stream_t implicit none contains <> end submodule vamp2_s @ %def vamp2_s @ <>= @ <>= use request_base use request_simple use request_caller use balancer_base use request_callback use mpi_f08 !NODEP! @ \subsection{Type: vamp2\_func\_t} \label{sec:vamp2-func} We extend [[vegas_func_t]] with the multi-channel weights and the [[vegas_grid_t]], such that, the overall multi-channel weight can be calculated by the function itself. We add an additional logicial [[valid_x]], if it is set to [[.false.]], we do not compute weighted function and just set the weighted integrand to zero. This behavior is in particular very useful, if a mapping is prohibited or fails. Or in the case of WHIZARD, a phase cut is applied. <>= public :: vamp2_func_t <>= type, abstract, extends(vegas_func_t) :: vamp2_func_t integer :: current_channel = 0 integer :: n_dim = 0 integer :: n_channel = 0 integer :: n_calls = 0 logical :: valid_x = .false. real(default), dimension(:, :), allocatable :: xi real(default), dimension(:), allocatable :: det real(default), dimension(:), allocatable :: wi real(default), dimension(:), allocatable :: gi type(vegas_grid_t), dimension(:), allocatable :: grids real(default) :: g = 0._default contains <> end type vamp2_func_t @ %def vamp2_func_t @ Init. <>= procedure, public :: init => vamp2_func_init <>= module subroutine vamp2_func_init (self, n_dim, n_channel) class(vamp2_func_t), intent(out) :: self integer, intent(in) :: n_dim integer, intent(in) :: n_channel end subroutine vamp2_func_init <>= module subroutine vamp2_func_init (self, n_dim, n_channel) class(vamp2_func_t), intent(out) :: self integer, intent(in) :: n_dim integer, intent(in) :: n_channel self%n_dim = n_dim self%n_channel = n_channel allocate (self%xi(n_dim, n_channel), source=0._default) allocate (self%det(n_channel), source=1._default) allocate (self%wi(n_channel), source=0._default) allocate (self%gi(n_channel), source=0._default) allocate (self%grids(n_channel)) end subroutine vamp2_func_init @ %def vamp2_func_init @ Set current channel. <>= procedure, public :: set_channel => vamp2_func_set_channel <>= module subroutine vamp2_func_set_channel (self, channel) class(vamp2_func_t), intent(inout) :: self integer, intent(in) :: channel end subroutine vamp2_func_set_channel <>= module subroutine vamp2_func_set_channel (self, channel) class(vamp2_func_t), intent(inout) :: self integer, intent(in) :: channel self%current_channel = channel end subroutine vamp2_func_set_channel @ %def vamp2_func_set_channel @ Get number of function calls for which $f \neq 0$. <>= procedure, public :: get_n_calls => vamp2_func_get_n_calls <>= module function vamp2_func_get_n_calls (self) result (n_calls) class(vamp2_func_t), intent(in) :: self integer :: n_calls end function vamp2_func_get_n_calls <>= module function vamp2_func_get_n_calls (self) result (n_calls) class(vamp2_func_t), intent(in) :: self integer :: n_calls n_calls = self%n_calls end function vamp2_func_get_n_calls @ %def vamp2_func_get_func_calls @ Reset number of calls. <>= procedure, public :: reset_n_calls => vamp2_func_reset_n_calls <>= module subroutine vamp2_func_reset_n_calls (self) class(vamp2_func_t), intent(inout) :: self end subroutine vamp2_func_reset_n_calls <>= module subroutine vamp2_func_reset_n_calls (self) class(vamp2_func_t), intent(inout) :: self self%n_calls = 0 end subroutine vamp2_func_reset_n_calls @ %def vamp2_func_reset_n_calls @ Evaluate mappings. We defer this method to be implemented by the user. The result must be written to [[xi]] and [[det]]. The mapping is defined by $\phi : U \rightarrow M$. We map $x \in M$ to the different mappings of the hypercube $U_{i}$, such that $x_{i} \in U_{i}$. The mapping should determine, whether [[x]] is a valid point, e.g. can be mapped, or is restricted otherwise. <>= procedure(vamp2_func_evaluate_maps), deferred :: evaluate_maps <>= abstract interface subroutine vamp2_func_evaluate_maps (self, x) import :: vamp2_func_t, default class(vamp2_func_t), intent(inout) :: self real(default), dimension(:), intent(in) :: x end subroutine vamp2_func_evaluate_maps end interface @ %def vamp2_evaluate_func @ Evaluate channel weights. The calling procedure must handle the case of a vanishing overall probability density where either a channel weight or a channel probability vanishes. <>= procedure, private :: evaluate_weight => vamp2_func_evaluate_weight <>= module subroutine vamp2_func_evaluate_weight (self) class(vamp2_func_t), intent(inout) :: self end subroutine vamp2_func_evaluate_weight <>= module subroutine vamp2_func_evaluate_weight (self) class(vamp2_func_t), intent(inout) :: self integer :: ch self%g = 0 self%gi = 0 !$OMP PARALLEL DO PRIVATE(ch) SHARED(self) do ch = 1, self%n_channel if (self%wi(ch) /= 0) then self%gi(ch) = self%grids(ch)%get_probability (self%xi(:, ch)) end if end do !$OMP END PARALLEL DO if (self%gi(self%current_channel) /= 0) then do ch = 1, self%n_channel if (self%wi(ch) /= 0 .and. self%det(ch) /= 0) then self%g = self%g + self%wi(ch) * self%gi(ch) / self%det(ch) end if end do self%g = self%g / self%gi(self%current_channel) end if end subroutine vamp2_func_evaluate_weight @ %def vamp2_func_evaluate_weight @ Evaluate function at [[x]]. We call this procedure in [[vamp2_func_evaluate]]. <>= procedure(vamp2_func_evaluate_func), deferred :: evaluate_func <>= abstract interface real(default) function vamp2_func_evaluate_func (self, x) result (f) import :: vamp2_func_t, default class(vamp2_func_t), intent(in) :: self real(default), dimension(:), intent(in) :: x end function vamp2_func_evaluate_func end interface @ %def vamp2_func_evaluate_func <>= procedure, public :: evaluate => vamp2_func_evaluate <>= module function vamp2_func_evaluate (self, x) result (f) class(vamp2_func_t), intent(inout) :: self real(default) :: f real(default), dimension(:), intent(in) :: x end function vamp2_func_evaluate <>= module function vamp2_func_evaluate (self, x) result (f) class(vamp2_func_t), intent(inout) :: self real(default) :: f real(default), dimension(:), intent(in) :: x call self%evaluate_maps (x) f = 0. self%gi = 0. self%g = 1 if (self%valid_x) then call self%evaluate_weight () if (self%g /= 0) then f = self%evaluate_func (x) / self%g self%n_calls = self%n_calls + 1 end if end if end function vamp2_func_evaluate @ %def vamp2_func_evaluate \subsection{Type: vamp2\_config\_t} \label{sec:vamp2-config} This is a transparent container which incorporates and extends the definitions in [[vegas_config]]. The parent object can then be used to parametrise the VEGAS grids directly, where the new parameters are exclusively used in the multi-channel implementation of VAMP2. [[n_calls_min]] is calculated by [[n_calls_min_per_channel]] and [[n_channel]]. The channels weights (and the result [[n_calls]] for each channel) are calculated regarding [[n_calls_threshold]]. <>= public :: vamp2_config_t <>= type, extends(vegas_config_t) :: vamp2_config_t integer :: n_channel = 0 integer :: n_calls_min_per_channel = 20 integer :: n_calls_threshold = 10 integer :: n_chains = 0 logical :: stratified = .true. logical :: equivalences = .false. real(default) :: beta = 0.5_default real(default) :: accuracy_goal = 0._default real(default) :: error_goal = 0._default real(default) :: rel_error_goal = 0._default contains <> end type vamp2_config_t @ %def vamp2_config_t @ Write. <>= procedure, public :: write => vamp2_config_write <>= module subroutine vamp2_config_write (self, unit, indent) class(vamp2_config_t), intent(in) :: self integer, intent(in), optional :: unit integer, intent(in), optional :: indent end subroutine vamp2_config_write <>= module subroutine vamp2_config_write (self, unit, indent) class(vamp2_config_t), intent(in) :: self integer, intent(in), optional :: unit integer, intent(in), optional :: indent integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call self%vegas_config_t%write (unit, indent) call write_indent (u, ind) write (u, "(2x,A,I0)") & & "Number of channels = ", self%n_channel call write_indent (u, ind) write (u, "(2x,A,I0)") & & "Min. number of calls per channel (setting calls) = ", & & self%n_calls_min_per_channel call write_indent (u, ind) write (u, "(2x,A,I0)") & & "Threshold number of calls (adapting weights) = ", & & self%n_calls_threshold call write_indent (u, ind) write (u, "(2x,A,I0)") & & "Number of chains = ", self%n_chains call write_indent (u, ind) write (u, "(2x,A,L1)") & & "Stratified = ", self%stratified call write_indent (u, ind) write (u, "(2x,A,L1)") & & "Equivalences = ", self%equivalences call write_indent (u, ind) write (u, "(2x,A," // FMT_17 // ")") & & "Adaption power (beta) = ", self%beta if (self%accuracy_goal > 0) then call write_indent (u, ind) write (u, "(2x,A," // FMT_17 // ")") & & "accuracy_goal = ", self%accuracy_goal end if if (self%error_goal > 0) then call write_indent (u, ind) write (u, "(2x,A," // FMT_17 // ")") & & "error_goal = ", self%error_goal end if if (self%rel_error_goal > 0) then call write_indent (u, ind) write (u, "(2x,A," // FMT_17 // ")") & & "rel_error_goal = ", self%rel_error_goal end if end subroutine vamp2_config_write @ %def vamp2_config_write @ \subsection{Type: vamp2\_result\_t} \label{sec:vamp2-result} This is a transparent container which incorporates and extends the definitions of [[vegas_result_t]]. <>= public :: vamp2_result_t <>= type, extends(vegas_result_t) :: vamp2_result_t contains <> end type vamp2_result_t @ %def vamp2_result_t @ Output. <>= procedure, public :: write => vamp2_result_write <>= module subroutine vamp2_result_write (self, unit, indent) class(vamp2_result_t), intent(in) :: self integer, intent(in), optional :: unit integer, intent(in), optional :: indent end subroutine vamp2_result_write <>= module subroutine vamp2_result_write (self, unit, indent) class(vamp2_result_t), intent(in) :: self integer, intent(in), optional :: unit integer, intent(in), optional :: indent integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call self%vegas_result_t%write (unit, indent) end subroutine vamp2_result_write @ %def vamp2_result_write @ \subsection{Type: vamp2\_equivalences\_t} \label{sec:vamp2-eqv} <>= integer, parameter, public :: & VEQ_IDENTITY = 0, VEQ_INVERT = 1, VEQ_SYMMETRIC = 2, VEQ_INVARIANT = 3 @ @ Channel equivalences. Store retrieving and sourcing channel. <>= type :: vamp2_equi_t integer :: ch integer :: ch_src integer, dimension(:), allocatable :: perm integer, dimension(:), allocatable :: mode contains <> end type vamp2_equi_t @ %def vamp2_equi_t @ Write equivalence. <>= procedure :: write => vamp2_equi_write <>= module subroutine vamp2_equi_write (self, unit, indent) class(vamp2_equi_t), intent(in) :: self integer, intent(in), optional :: unit integer, intent(in), optional :: indent end subroutine vamp2_equi_write <>= module subroutine vamp2_equi_write (self, unit, indent) class(vamp2_equi_t), intent(in) :: self integer, intent(in), optional :: unit integer, intent(in), optional :: indent integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call write_indent (u, ind) write (u, "(2(A,1X,I0))") "src:", self%ch_src, "-> dest:", self%ch call write_indent (u, ind) write (u, "(A,99(1X,I0))") "Perm: ", self%perm call write_indent (u, ind) write (u, "(A,99(1X,I0))") "Mode: ", self%mode end subroutine vamp2_equi_write @ %def vamp2_equi_write @ <>= public :: vamp2_equivalences_t <>= type :: vamp2_equivalences_t private integer :: n_eqv = 0 integer :: n_channel = 0 integer :: n_dim = 0 type(vamp2_equi_t), dimension(:), allocatable :: eqv integer, dimension(:), allocatable :: map integer, dimension(:), allocatable :: multiplicity integer, dimension(:), allocatable :: symmetry logical, dimension(:), allocatable :: independent integer, dimension(:), allocatable :: equivalent_to_ch logical, dimension(:,:), allocatable :: dim_is_invariant contains <> end type vamp2_equivalences_t @ %def vamp2_equivalences_t @ Constructor. <>= interface vamp2_equivalences_t module procedure vamp2_equivalences_init end interface vamp2_equivalences_t <>= module function vamp2_equivalences_init (n_eqv, n_channel, & n_dim) result (eqv) type(vamp2_equivalences_t) :: eqv integer, intent(in) :: n_eqv, n_channel, n_dim end function vamp2_equivalences_init <>= module function vamp2_equivalences_init (n_eqv, n_channel, & n_dim) result (eqv) type(vamp2_equivalences_t) :: eqv integer, intent(in) :: n_eqv, n_channel, n_dim eqv%n_eqv = n_eqv eqv%n_channel = n_channel eqv%n_dim = n_dim allocate (eqv%eqv(n_eqv)) allocate (eqv%map(n_channel), source = 0) allocate (eqv%multiplicity(n_channel), source = 0) allocate (eqv%symmetry(n_channel), source = 0) allocate (eqv%independent(n_channel), source = .true.) allocate (eqv%equivalent_to_ch(n_channel), source = 0) allocate (eqv%dim_is_invariant(n_dim, n_channel), source = .false.) end function vamp2_equivalences_init @ %def vamp2_equivlences_init @ Write equivalences. <>= procedure :: write => vamp2_equivalences_write <>= module subroutine vamp2_equivalences_write (self, unit, indent) class(vamp2_equivalences_t), intent(in) :: self integer, intent(in), optional :: unit integer, intent(in), optional :: indent end subroutine vamp2_equivalences_write <>= module subroutine vamp2_equivalences_write (self, unit, indent) class(vamp2_equivalences_t), intent(in) :: self integer, intent(in), optional :: unit integer, intent(in), optional :: indent integer :: u, ind, i_eqv, ch u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent write (u, "(A)") "Inequivalent channels:" if (allocated (self%independent)) then do ch = 1, self%n_channel if (self%independent(ch)) then write (u, "(2X,A,1x,I0,A,4x,A,I0,4x,A,I0,4x,A,999(L1))") & "Channel", ch, ":", & "Mult. = ", self%multiplicity(ch), & "Symm. = ", self%symmetry(ch), & "Invar.: ", self%dim_is_invariant(:, ch) end if end do else write (u, "(A)") "[not allocated]" end if write (u, "(A)") "Equivalence list:" if (allocated (self%eqv)) then do i_eqv = 1, self%n_eqv write (u, "(2X,A,1X,I0)") "i_eqv:", i_eqv call self%eqv(i_eqv)%write (unit, indent = ind + 4) end do else write (u, "(A)") "[not allocated]" end if end subroutine vamp2_equivalences_write @ %def vamp2_equivalences_write @ Is allocated. <>= procedure, public :: is_allocated => vamp2_equivalences_is_allocated <>= module function vamp2_equivalences_is_allocated (self) result (yorn) class(vamp2_equivalences_t), intent(in) :: self logical :: yorn end function vamp2_equivalences_is_allocated <>= module function vamp2_equivalences_is_allocated (self) result (yorn) class(vamp2_equivalences_t), intent(in) :: self logical :: yorn yorn = allocated (self%eqv) end function vamp2_equivalences_is_allocated @ %def vamp2_equivalences_is_allocated @ Get source channel and destination channel for given equivalence. <>= procedure, public :: get_channels => vamp2_equivalences_get_channels <>= module subroutine vamp2_equivalences_get_channels (eqv, i_eqv, dest, src) class(vamp2_equivalences_t), intent(in) :: eqv integer, intent(in) :: i_eqv integer, intent(out) :: dest, src end subroutine vamp2_equivalences_get_channels <>= module subroutine vamp2_equivalences_get_channels (eqv, i_eqv, dest, src) class(vamp2_equivalences_t), intent(in) :: eqv integer, intent(in) :: i_eqv integer, intent(out) :: dest, src dest = eqv%eqv(i_eqv)%ch src = eqv%eqv(i_eqv)%ch_src end subroutine vamp2_equivalences_get_channels @ %def vamp2_equivalences_get_channels @ <>= procedure, public :: get_mode => vamp2_equivalences_get_mode procedure, public :: get_perm => vamp2_equivalences_get_perm <>= module function vamp2_equivalences_get_mode (eqv, i_eqv) result (mode) class(vamp2_equivalences_t), intent(in) :: eqv integer, intent(in) :: i_eqv integer, dimension(:), allocatable :: mode end function vamp2_equivalences_get_mode module function vamp2_equivalences_get_perm (eqv, i_eqv) result (perm) class(vamp2_equivalences_t), intent(in) :: eqv integer, intent(in) :: i_eqv integer, dimension(:), allocatable :: perm end function vamp2_equivalences_get_perm <>= module function vamp2_equivalences_get_mode (eqv, i_eqv) result (mode) class(vamp2_equivalences_t), intent(in) :: eqv integer, intent(in) :: i_eqv integer, dimension(:), allocatable :: mode mode = eqv%eqv(i_eqv)%mode end function vamp2_equivalences_get_mode module function vamp2_equivalences_get_perm (eqv, i_eqv) result (perm) class(vamp2_equivalences_t), intent(in) :: eqv integer, intent(in) :: i_eqv integer, dimension(:), allocatable :: perm perm = eqv%eqv(i_eqv)%perm end function vamp2_equivalences_get_perm @ %def vamp2_equivalences_get_perm, vamp2_equivalences_get_mode @ <>= procedure, public :: set_equivalence => & vamp2_equivalences_set_equivalence <>= module subroutine vamp2_equivalences_set_equivalence & (eqv, i_eqv, dest, src, perm, mode) class(vamp2_equivalences_t), intent(inout) :: eqv integer, intent(in) :: i_eqv integer, intent(in) :: dest, src integer, dimension(:), intent(in) :: perm, mode end subroutine vamp2_equivalences_set_equivalence <>= module subroutine vamp2_equivalences_set_equivalence & (eqv, i_eqv, dest, src, perm, mode) class(vamp2_equivalences_t), intent(inout) :: eqv integer, intent(in) :: i_eqv integer, intent(in) :: dest, src integer, dimension(:), intent(in) :: perm, mode integer :: i if (dest < 1 .or. dest > eqv%n_channel) call msg_bug & ("VAMP2: set_equivalences: destination channel out of range.") if (src < 1 .or. src > eqv%n_channel) call msg_bug & ("VAMP2: set_equivalences: source channel out of range.") if (size(perm) /= eqv%n_dim) call msg_bug & ("VAMP2: set_equivalences: size(perm) does not match n_dim.") if (size(mode) /= eqv%n_dim) call msg_bug & ("VAMP2: set_equivalences: size(mode) does not match n_dim.") eqv%eqv(i_eqv)%ch = dest eqv%eqv(i_eqv)%ch_src = src allocate (eqv%eqv(i_eqv)%perm (size (perm))) do i = 1, size (perm) eqv%eqv(i_eqv)%perm(i) = perm(i) end do allocate (eqv%eqv(i_eqv)%mode (size (mode))) do i = 1, size (mode) eqv%eqv(i_eqv)%mode(i) = mode(i) end do end subroutine vamp2_equivalences_set_equivalence @ %def vamp2_equivalences_set_equivalence @ Freeze equivalences. <>= procedure, public :: freeze => vamp2_equivalences_freeze <>= module subroutine vamp2_equivalences_freeze (self) class(vamp2_equivalences_t), intent(inout) :: self end subroutine vamp2_equivalences_freeze <>= module subroutine vamp2_equivalences_freeze (self) class(vamp2_equivalences_t), intent(inout) :: self integer :: i_eqv, ch, upper, lower ch = 0 do i_eqv = 1, self%n_eqv if (ch /= self%eqv(i_eqv)%ch) then ch = self%eqv(i_eqv)%ch self%map(ch) = i_eqv end if end do do ch = 1, self%n_channel lower = self%map(ch) if (ch == self%n_channel) then upper = self%n_eqv else upper = self%map(ch + 1) - 1 end if associate (eqv => self%eqv, n_eqv => size (self%eqv(lower:upper))) if (.not. all(eqv(lower:upper)%ch == ch) .or. & eqv(lower)%ch_src > ch) then do i_eqv = lower, upper call self%eqv(i_eqv)%write () end do call msg_bug ("VAMP2: vamp2_equivalences_freeze: & &equivalence order is not correct.") end if self%symmetry(ch) = count (eqv(lower:upper)%ch_src == ch) if (mod (n_eqv, self%symmetry(ch)) /= 0) then do i_eqv = lower, upper call self%eqv(i_eqv)%write () end do call msg_bug ("VAMP2: vamp2_equivalences_freeze: & &permutation count is not correct.") end if self%multiplicity(ch) = n_eqv / self%symmetry(ch) self%independent(ch) = all (eqv(lower:upper)%ch_src >= ch) self%equivalent_to_ch(ch) = eqv(lower)%ch_src self%dim_is_invariant(:, ch) = eqv(lower)%mode == VEQ_INVARIANT end associate end do end subroutine vamp2_equivalences_freeze @ %def vamp2_equivalences_freeze @ \subsection{Type: vamp2\_t} \label{sec:vamp2-t} <>= public :: vamp2_t <>= type :: vamp2_t private type(vamp2_config_t) :: config type(vegas_t), dimension(:), allocatable :: integrator integer, dimension(:), allocatable :: chain real(default), dimension(:), allocatable :: weight real(default), dimension(:), allocatable :: integral real(default), dimension(:), allocatable :: variance real(default), dimension(:), allocatable :: efficiency type(vamp2_result_t) :: result type(vamp2_equivalences_t) :: equivalences logical :: event_prepared real(default), dimension(:), allocatable :: event_weight <> contains <> end type vamp2_t <>= class(request_base_t), allocatable :: request <>= interface vamp2_t module procedure vamp2_init end interface vamp2_t @ %def vamp2_t @ Constructor. <>= module function vamp2_init (n_channel, n_dim, alpha, beta, n_bins_max,& & n_calls_min_per_channel, iterations, mode) result (self) type(vamp2_t) :: self integer, intent(in) :: n_channel integer, intent(in) :: n_dim integer, intent(in), optional :: n_bins_max integer, intent(in), optional :: n_calls_min_per_channel real(default), intent(in), optional :: alpha real(default), intent(in), optional :: beta integer, intent(in), optional :: iterations integer, intent(in), optional :: mode end function vamp2_init <>= module function vamp2_init (n_channel, n_dim, alpha, beta, n_bins_max,& & n_calls_min_per_channel, iterations, mode) result (self) type(vamp2_t) :: self integer, intent(in) :: n_channel integer, intent(in) :: n_dim integer, intent(in), optional :: n_bins_max integer, intent(in), optional :: n_calls_min_per_channel real(default), intent(in), optional :: alpha real(default), intent(in), optional :: beta integer, intent(in), optional :: iterations integer, intent(in), optional :: mode integer :: ch self%config%n_dim = n_dim self%config%n_channel = n_channel call set_options () allocate (self%chain(n_channel), source=0) allocate (self%integrator(n_channel)) allocate (self%weight(n_channel), source=0._default) do ch = 1, n_channel self%integrator(ch) = vegas_t (n_dim, alpha, n_bins_max, 1, mode) end do self%weight = 1._default / self%config%n_channel call self%reset_result () allocate (self%event_weight(self%config%n_channel), source = 0._default) self%event_prepared = .false. contains subroutine set_options () if (present (n_bins_max)) self%config%n_bins_max = n_bins_max if (present (n_calls_min_per_channel)) & self%config%n_calls_min_per_channel = n_calls_min_per_channel if (present (alpha)) self%config%alpha = alpha if (present (beta)) self%config%beta = beta if (present (iterations)) self%config%iterations = iterations if (present (mode)) self%config%mode = mode end subroutine set_options end function vamp2_init @ %def vamp2_init <>= procedure, public :: final => vamp2_final <>= module subroutine vamp2_final (self) class(vamp2_t), intent(inout) :: self end subroutine vamp2_final <>= module subroutine vamp2_final (self) class(vamp2_t), intent(inout) :: self integer :: ch do ch = 1, self%config%n_channel call self%integrator(ch)%final () end do end subroutine vamp2_final @ %def vamp2_final @ Output. <>= procedure, public :: write => vamp2_write <>= module subroutine vamp2_write (self, unit, indent) class(vamp2_t), intent(in) :: self integer, intent(in), optional :: unit integer, intent(in), optional :: indent end subroutine vamp2_write <>= module subroutine vamp2_write (self, unit, indent) class(vamp2_t), intent(in) :: self integer, intent(in), optional :: unit integer, intent(in), optional :: indent integer :: u, ind, ch u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call write_indent (u, ind) write (u, "(A)") "VAMP2: VEGAS AMPlified 2" call write_indent (u, ind) call self%config%write (unit, indent) call self%result%write (unit, indent) end subroutine vamp2_write @ %def vamp2_write @ Get the config object. <>= procedure, public :: get_config => vamp2_get_config <>= module subroutine vamp2_get_config (self, config) class(vamp2_t), intent(in) :: self type(vamp2_config_t), intent(out) :: config end subroutine vamp2_get_config <>= module subroutine vamp2_get_config (self, config) class(vamp2_t), intent(in) :: self type(vamp2_config_t), intent(out) :: config config = self%config end subroutine vamp2_get_config @ %def vamp2_get_config @ Set non-runtime dependent configuration. It will no be possible to change [[n_bins_max]]. <>= procedure, public :: set_config => vamp2_set_config <>= module subroutine vamp2_set_config (self, config) class(vamp2_t), intent(inout) :: self class(vamp2_config_t), intent(in) :: config end subroutine vamp2_set_config <>= module subroutine vamp2_set_config (self, config) class(vamp2_t), intent(inout) :: self class(vamp2_config_t), intent(in) :: config integer :: ch self%config%equivalences = config%equivalences self%config%n_calls_min_per_channel = config%n_calls_min_per_channel self%config%n_calls_threshold = config%n_calls_threshold self%config%n_calls_min = config%n_calls_min self%config%beta = config%beta self%config%accuracy_goal = config%accuracy_goal self%config%error_goal = config%error_goal self%config%rel_error_goal = config%rel_error_goal do ch = 1, self%config%n_channel call self%integrator(ch)%set_config (config) end do end subroutine vamp2_set_config @ %def vamp2_set_config @ Set the overall number of calls. The number of calls each channel is scaled by the channel weights \begin{equation} N_i = \alpha_i N. \end{equation} <>= procedure, public :: set_calls => vamp2_set_n_calls <>= module subroutine vamp2_set_n_calls (self, n_calls) class(vamp2_t), intent(inout) :: self integer, intent(in) :: n_calls end subroutine vamp2_set_n_calls <>= module subroutine vamp2_set_n_calls (self, n_calls) class(vamp2_t), intent(inout) :: self integer, intent(in) :: n_calls integer :: ch self%config%n_calls_min = self%config%n_calls_min_per_channel & & * self%config%n_channel self%config%n_calls = max(n_calls, self%config%n_calls_min) if (self%config%n_calls > n_calls) then write (msg_buffer, "(A,I0)") "VAMP2: [set_calls] number of calls too few,& & reset to = ", self%config%n_calls call msg_message () end if do ch = 1, self%config%n_channel call self%integrator(ch)%set_calls (max (nint (self%config%n_calls *& & self%weight(ch)), self%config%n_calls_min_per_channel)) end do end subroutine vamp2_set_n_calls @ %def vamp2_set_n_calls @ Set limits. We only support same limits for all channels. <>= procedure, public :: set_limits => vamp2_set_limits <>= module subroutine vamp2_set_limits (self, x_upper, x_lower) class(vamp2_t), intent(inout) :: self real(default), dimension(:), intent(in) :: x_upper real(default), dimension(:), intent(in) :: x_lower end subroutine vamp2_set_limits <>= module subroutine vamp2_set_limits (self, x_upper, x_lower) class(vamp2_t), intent(inout) :: self real(default), dimension(:), intent(in) :: x_upper real(default), dimension(:), intent(in) :: x_lower integer :: ch do ch = 1, self%config%n_channel call self%integrator(ch)%set_limits (x_upper, x_lower) end do end subroutine vamp2_set_limits @ %def vamp2_set_limits @ Set [[n_chains]] and the (actual) chains. [[chain]] must have size [[n_channels]] and each elements must store an index to a corresponding chain. This means, that channels with equal index correspond to the same chain, and we refer to those as chained weights, where we average the contributions of the chained weights in [[vamp2_adapt_weights]]. <>= procedure, public :: set_chain => vamp2_set_chain <>= module subroutine vamp2_set_chain (self, n_chains, chain) class(vamp2_t), intent(inout) :: self integer, intent(in) :: n_chains integer, dimension(:), intent(in) :: chain end subroutine vamp2_set_chain <>= module subroutine vamp2_set_chain (self, n_chains, chain) class(vamp2_t), intent(inout) :: self integer, intent(in) :: n_chains integer, dimension(:), intent(in) :: chain if (size (chain) /= self%config%n_channel) then call msg_bug ("VAMP2: set chain: size of chain array does not match n_channel.") else call msg_message ("VAMP2: set chain: use chained weights.") end if self%config%n_chains = n_chains self%chain = chain end subroutine vamp2_set_chain @ %def vamp2_set_chain @ Set channel equivalences. <>= procedure, public :: set_equivalences => vamp2_set_equivalences <>= module subroutine vamp2_set_equivalences (self, equivalences) class(vamp2_t), intent(inout) :: self type(vamp2_equivalences_t), intent(in) :: equivalences end subroutine vamp2_set_equivalences <>= module subroutine vamp2_set_equivalences (self, equivalences) class(vamp2_t), intent(inout) :: self type(vamp2_equivalences_t), intent(in) :: equivalences self%equivalences = equivalences end subroutine vamp2_set_equivalences @ %def vamp2_set_equivalences @ Move allocated (and prepared!) request object into VAMP2. Gfortran 7/8/9 bug, has to remain in the main module. <>= generic, public :: allocate_request => allocate_request_by_method, & allocate_request_by_object procedure, private :: allocate_request_by_method => vamp2_allocate_request_by_method procedure, private :: allocate_request_by_object => vamp2_allocate_request_by_object <>= subroutine vamp2_allocate_request_by_method (self, method) class(vamp2_t), intent(inout) :: self character(len=*), intent(in) :: method class(request_base_t), allocatable :: request select case (trim(method)) case("simple", "Simple", "SIMPLE") allocate (request_simple_t :: request) case("load", "Load", "LOAD") allocate (request_caller_t :: request) case default call msg_bug ("VAMP2: Unknown method for MPI request module.") end select select type (request) type is (request_simple_t) call request%init (MPI_COMM_WORLD, n_channels = self%config%n_channel) type is (request_caller_t) call request%init (MPI_COMM_WORLD, n_channels = self%config%n_channel) end select call self%allocate_request_by_object (request) end subroutine vamp2_allocate_request_by_method subroutine vamp2_allocate_request_by_object (self, request) class(vamp2_t), intent(inout) :: self class(request_base_t), allocatable, intent(inout) :: request !! Only output in case of "parallel" integration. if (request%has_workers ()) then select type (request) type is (request_simple_t) call msg_message ("VAMP2: Simple Request Balancing.") type is (request_caller_t) call msg_message ("VAMP2: Request with load balancing.") class default call msg_bug ("VAMP2: Unknown extension of request_base.") end select end if call move_alloc (request, self%request) end subroutine vamp2_allocate_request_by_object @ %def vamp2_allocate_request @ Get [[n_calls]] calculated by [[VEGAS]]. <>= procedure, public :: get_n_calls => vamp2_get_n_calls <>= elemental module function vamp2_get_n_calls (self) result (n_calls) class(vamp2_t), intent(in) :: self real(default) :: n_calls end function vamp2_get_n_calls <>= elemental module function vamp2_get_n_calls (self) result (n_calls) class(vamp2_t), intent(in) :: self real(default) :: n_calls n_calls = sum (self%integrator%get_calls ()) end function vamp2_get_n_calls @ %def vamp2_get_n_calls @ Get the cumulative result of the integration. Recalculate weighted average of the integration. <>= procedure, public :: get_integral => vamp2_get_integral <>= elemental module function vamp2_get_integral (self) result (integral) class(vamp2_t), intent(in) :: self real(default) :: integral end function vamp2_get_integral <>= elemental module function vamp2_get_integral (self) result (integral) class(vamp2_t), intent(in) :: self real(default) :: integral integral = 0. if (self%result%sum_wgts > 0.) then integral = self%result%sum_int_wgtd / self%result%sum_wgts end if end function vamp2_get_integral @ %def vamp2_get_integral @ Get the cumulative variance of the integration. Recalculate the variance. <>= procedure, public :: get_variance => vamp2_get_variance <>= elemental module function vamp2_get_variance (self) result (variance) class(vamp2_t), intent(in) :: self real(default) :: variance end function vamp2_get_variance <>= elemental module function vamp2_get_variance (self) result (variance) class(vamp2_t), intent(in) :: self real(default) :: variance variance = 0 if (self%result%sum_wgts > 0.) then variance = 1.0 / self%result%sum_wgts end if end function vamp2_get_variance @ %def vamp2_get_variance @ Get efficiency. <>= procedure, public :: get_efficiency => vamp2_get_efficiency <>= elemental module function vamp2_get_efficiency (self) result (efficiency) class(vamp2_t), intent(in) :: self real(default) :: efficiency end function vamp2_get_efficiency <>= elemental module function vamp2_get_efficiency (self) result (efficiency) class(vamp2_t), intent(in) :: self real(default) :: efficiency efficiency = 0. if (self%result%efficiency > 0.) then efficiency = self%result%efficiency end if end function vamp2_get_efficiency @ %def vamp2_get_efficiency @ Get event weight and event weight excess. <>= procedure :: get_evt_weight => vamp2_get_evt_weight procedure :: get_evt_weight_excess => vamp2_get_evt_weight_excess <>= module function vamp2_get_evt_weight (self) result (evt_weight) class(vamp2_t), intent(in) :: self real(default) :: evt_weight end function vamp2_get_evt_weight module function vamp2_get_evt_weight_excess (self) result (evt_weight_excess) class(vamp2_t), intent(in) :: self real(default) :: evt_weight_excess end function vamp2_get_evt_weight_excess <>= module function vamp2_get_evt_weight (self) result (evt_weight) class(vamp2_t), intent(in) :: self real(default) :: evt_weight evt_weight = self%result%evt_weight end function vamp2_get_evt_weight module function vamp2_get_evt_weight_excess (self) result (evt_weight_excess) class(vamp2_t), intent(in) :: self real(default) :: evt_weight_excess evt_weight_excess = self%result%evt_weight_excess end function vamp2_get_evt_weight_excess @ %def vamp2_get_evt_weight, vamp2_get_evt_weight_excess @ Get procedure to retrieve channel-th grid. <>= procedure :: get_grid => vamp2_get_grid <>= module function vamp2_get_grid (self, channel) result (grid) class(vamp2_t), intent(in) :: self type(vegas_grid_t) :: grid integer, intent(in) :: channel end function vamp2_get_grid <>= module function vamp2_get_grid (self, channel) result (grid) class(vamp2_t), intent(in) :: self type(vegas_grid_t) :: grid integer, intent(in) :: channel if (channel < 1 .or. channel > self%config%n_channel) & call msg_bug ("VAMP2: vamp2_get_grid: channel index < 1 or > n_channel.") grid = self%integrator(channel)%get_grid () end function vamp2_get_grid @ %def vamp2_get_grid @ Adapt. We adapt the weights due the contribution of variances with $\beta > 0$. \begin{equation} \alpha_i = \frac{\alpha_i V_i^\beta}{\sum_i \alpha_i V_i^\beta} \end{equation} If [[n_calls_threshold]] is set, we rescale the weights in such a way, that the [[n_calls]] for each channel are greater than [[n_calls_threshold]]. We calculate the distance of the weights to the [[weight_min]] and reset those weights which are less than [[weight_mins]] to this value. The other values are accordingly resized to fit the boundary condition of the partition of unity. <>= procedure, private :: adapt_weights => vamp2_adapt_weights <>= module subroutine vamp2_adapt_weights (self) class(vamp2_t), intent(inout) :: self end subroutine vamp2_adapt_weights <>= module subroutine vamp2_adapt_weights (self) class(vamp2_t), intent(inout) :: self integer :: n_weights_underflow real(default) :: weight_min, sum_weights_underflow self%weight = self%weight * self%integrator%get_variance ()**self%config%beta if (sum (self%weight) == 0) self%weight = real(self%config%n_calls, default) if (self%config%n_chains > 0) then call chain_weights () end if self%weight = self%weight / sum(self%weight) if (self%config%n_calls_threshold /= 0) then weight_min = real(self%config%n_calls_threshold, default) & & / self%config%n_calls sum_weights_underflow = sum (self%weight, self%weight < weight_min) n_weights_underflow = count (self%weight < weight_min) where (self%weight < weight_min) self%weight = weight_min elsewhere self%weight = self%weight * (1. - n_weights_underflow * weight_min) & & / (1. - sum_weights_underflow) end where end if call self%set_calls (self%config%n_calls) contains <> end subroutine vamp2_adapt_weights @ %def vamp2_adapt_weights @ We average the weights over their respective chain members. <>= subroutine chain_weights () integer :: ch real(default) :: average do ch = 1, self%config%n_chains average = max (sum (self%weight, self%chain == ch), 0._default) if (average /= 0) then average = average / count (self%chain == ch) where (self%chain == ch) self%weight = average end where end if end do end subroutine chain_weights @ %def chain_weights <>= procedure, private :: apply_equivalences => vamp2_apply_equivalences <>= module subroutine vamp2_apply_equivalences (self) class(vamp2_t), intent(inout) :: self end subroutine vamp2_apply_equivalences <>= module subroutine vamp2_apply_equivalences (self) class(vamp2_t), intent(inout) :: self integer :: ch, ch_src, j, j_src, i_eqv real(default), dimension(:, :, :), allocatable :: d real(default), dimension(:, :), allocatable :: d_src integer, dimension(:), allocatable :: mode, perm if (.not. self%equivalences%is_allocated ()) then call msg_bug ("VAMP2: vamp2_apply_equivalences: & &cannot apply not-allocated equivalences.") end if allocate (d(self%config%n_bins_max, self%config%n_dim, & self%config%n_channel), source=0._default) associate (eqv => self%equivalences, nb => self%config%n_bins_max) do i_eqv = 1, self%equivalences%n_eqv call eqv%get_channels (i_eqv, ch, ch_src) d_src = self%integrator(ch_src)%get_distribution () mode = eqv%get_mode (i_eqv) perm = eqv%get_perm (i_eqv) do j = 1, self%config%n_dim select case (mode (j)) case (VEQ_IDENTITY) d(:, j, ch) = d(:, j, ch) + & d_src(:, perm(j)) case (VEQ_INVERT) d(:, j, ch) = d(:, j, ch) + & d_src(nb:1:-1, perm(j)) case (VEQ_SYMMETRIC) d(:, j, ch) = d(:, j, ch) + & d_src(:, perm(j)) / 2. + & d_src(nb:1:-1, perm(j)) / 2. case (VEQ_INVARIANT) d(:, j, ch) = 1._default end select end do end do end associate do ch = 1, self%config%n_channel call self%integrator(ch)%set_distribution (d(:, :, ch)) end do end subroutine vamp2_apply_equivalences @ %def vamp2_apply_equivalences @ Reset the cumulative result. <>= procedure, public :: reset_result => vamp2_reset_result <>= module subroutine vamp2_reset_result (self) class(vamp2_t), intent(inout) :: self end subroutine vamp2_reset_result <>= module subroutine vamp2_reset_result (self) class(vamp2_t), intent(inout) :: self call self%result%reset () end subroutine vamp2_reset_result @ %def vamp2_reset_result @ Integrate. We integrate each channel separately and combine the results \begin{align} I & = \sum_i \alpha_i I_i, \\ \sigma^2 & = \sum_i \alpha_i^2 \sigma^2_i. \end{align} Although, the (population) variance is given by \begin{equation} \begin{split} \sigma^2 & = \frac{1}{N} \left( \sum_i \alpha_i I^2_i - I^2 \right) \\ & = \frac{1}{N - 1} \left( \sum_i \left( N_i \sigma^2_i + I^2_i \right) -I^2 \right) \\ & = \frac{1}{N - 1} \left( \sum_i \alpha_i \sigma^2_i + \alpha_i I^2_i - I^2 \right), \end{split} \end{equation} where we used $\sigma^2_i = \frac{1}{N} \left( \langle I^2_i \rangle - \langle I_i \rangle^2 \right)$, we use the approximation for numeric stability. The population variance relates to sample variance \begin{equation} s^2 = \frac{n}{n - 1} \sigma^2, \end{equation} which gives an unbiased error estimate. Beside those adaption to multichannel, the overall processing of [[total_integral]], [[total_sq_integral]] and [[total_variance]] is the same as in [[vegas_integrate]]. <>= procedure, public :: integrate => vamp2_integrate <>= module subroutine vamp2_integrate (self, func, rng, iterations, & reset_result, refine_grids, adapt_weights, verbose, result, abserr) class(vamp2_t), intent(inout) :: self class(vamp2_func_t), intent(inout) :: func class(rng_t), intent(inout) :: rng integer, intent(in), optional :: iterations logical, intent(in), optional :: reset_result logical, intent(in), optional :: refine_grids logical, intent(in), optional :: adapt_weights logical, intent(in), optional :: verbose real(default), optional, intent(out) :: result, abserr end subroutine vamp2_integrate <>= module subroutine vamp2_integrate (self, func, rng, iterations, & reset_result, refine_grids, adapt_weights, verbose, result, abserr) class(vamp2_t), intent(inout) :: self class(vamp2_func_t), intent(inout) :: func class(rng_t), intent(inout) :: rng integer, intent(in), optional :: iterations logical, intent(in), optional :: reset_result logical, intent(in), optional :: refine_grids logical, intent(in), optional :: adapt_weights logical, intent(in), optional :: verbose real(default), optional, intent(out) :: result, abserr integer :: it, ch type(iterator_t) :: channel_iterator real(default) :: cumulative_int, cumulative_std logical :: opt_reset_result logical :: opt_adapt_weights logical :: opt_refine_grids logical :: opt_verbose <> call set_options () if (opt_verbose) then call msg_message ("Results: [it, calls, integral, error, chi^2, eff.]") end if if (opt_reset_result) call self%reset_result () <> iteration: do it = 1, self%config%iterations call channel_iterator%init (1, self%config%n_channel) call self%prepare_integrate_iteration (func) <> channel: do <> call func%set_channel (ch) call self%integrator(ch)%integrate ( & & func, rng, iterations, refine_grid = .false., verbose = .false.) <> call channel_iterator%next_step () end do channel <> call self%compute_result_and_efficiency () associate (result => self%result) cumulative_int = result%sum_int_wgtd / result%sum_wgts cumulative_std = sqrt (1 / result%sum_wgts) if (opt_verbose) then write (msg_buffer, "(I0,1x,I0,1x, 4(E24.16E4,1x))") & & it, self%config%n_calls, cumulative_int, cumulative_std, & & result%chi2, result%efficiency call msg_message () end if end associate if (opt_adapt_weights) then call self%adapt_weights () end if if (opt_refine_grids) then if (self%config%equivalences .and. self%equivalences%is_allocated ()) then call self%apply_equivalences () end if do ch = 1, self%config%n_channel !! When we apply the grid refinement outside of VEGAS, then we do not average over distribution !! as VEGAS averaged the distribution internally. call self%integrator(ch)%refine (average = .false.) end do end if end do iteration if (present (result)) result = cumulative_int if (present (abserr)) abserr = abs (cumulative_std) contains <> end subroutine vamp2_integrate @ %def vamp2_integrate @ Set optional parameters. <>= subroutine set_options () if (present (iterations)) self%config%iterations = iterations opt_reset_result = .true. if (present (reset_result)) opt_reset_result = reset_result opt_adapt_weights = .true. if (present (adapt_weights)) opt_adapt_weights = adapt_weights opt_refine_grids = .true. if (present (refine_grids)) opt_refine_grids = refine_grids opt_verbose = .false. if (present (verbose)) opt_verbose = verbose end subroutine set_options @ %def set_options @ We define additional chunks, which we use to insert parallel/MPI code. <>= @ <>= @ <>= @ Conditional handling. We introduce a different behavior for the MPI-/non-MPI variant. <>= if (.not. channel_iterator%is_iterable ()) exit channel ch = channel_iterator%get_current () @ <>= @ <>= @ <>= type(request_t) :: request @ Verify that we have an allocated request object, else fallback to simple method. Be aware that we keep the fallback silent (!) in order to keep any possible testing output uninterrupted. <>= if (.not. allocated (self%request)) then call self%allocate_request_by_method ("simple") end if @ <>= if (self%request%is_master ()) then select type (req => self%request) type is (request_caller_t) request%terminate = .true. call update_iter_and_rng (request, channel_iterator, rng) !! channel_iter is already drained for master. !! Do not descent into channel integration (later on). call req%handle_workload () end select end if @ Conditional handling for the MPI-version of sampling. We have a request object and an advanced [[channel_iterator]] and have to consider three cases: \begin{enumerate} \item [[channel_iterator]] drained, \item [[request]] terminated, \item [[request]] received. \end{enumerate} When the [[channel_iterator]] is drained by [[update_iter_and_rng]], we send a terminate request to the master and await in the next cycle of channel loop the terminated request. When the request is terminated, we can gracefully exit the channel loop as [[channel_iterator]] and [[rng]] are already advanced by [[update_iter_and_rng]]. When we received a genuine request, then, we proceed as prophisied. <>= select type (req => self%request) type is (request_caller_t) if (self%request%is_master ()) exit channel end select call self%request%request_workload (request) call update_iter_and_rng (request, channel_iterator, rng) if (request%terminate) then exit channel else if (.not. channel_iterator%is_iterable ()) then select type (req => self%request) type is (request_caller_t) call req%request_terminate () cycle channel class is (request_base_t) exit channel end select end if if (request%group) call MPI_BARRIER (request%comm) ch = request%handler_id call self%integrator(ch)%prepare_parallel_integrate(request%comm, & duplicate_comm = .false., & parallel_mode = request%group) @ <>= if (request%group_master) then if (.not. self%request%is_master ()) & call allocate_handler (self%request, ch) call self%request%handle_and_release_workload (request) else call self%request%release_workload (request) end if @ <>= call reduce_func_calls (func) call self%request%await_handler () call self%request%barrier () if (.not. self%request%is_master ()) cycle @ <>= subroutine allocate_handler (req, ch) class(request_base_t), intent(inout) :: req integer, intent(in) :: ch class(request_handler_t), pointer :: vegas_result_handler call self%integrator(ch)%allocate_handler (& handler_id = ch,& handler = vegas_result_handler) call req%add_handler (ch, vegas_result_handler) end subroutine allocate_handler !! Advance the random number generator for the skipped channels. !! !! We set current_channel = request%handler_id, hence, we need to advance !! the random number generator until th iterator returns the same channel. subroutine update_iter_and_rng (request, iter, rng) type(request_t), intent(in) :: request type(iterator_t), intent(inout) :: iter class(rng_t), intent(inout) :: rng advance: do while (iter%is_iterable ()) !! Advance up to iterator%end when in terminate mode, !! else advance until we hit the previous channel (i.e. request%handler_id - 1): !! Proof: current_channel <= request%handler_id - 1 if (.not. request%terminate) then if (iter%get_current () >= request%handler_id) & exit advance end if select type (rng) type is (rng_stream_t) call rng%next_substream () end select call iter%next_step () end do advance end subroutine update_iter_and_rng subroutine reduce_func_calls (func) class(vamp2_func_t), intent(inout) :: func type(MPI_COMM) :: comm integer :: root_n_calls call self%request%get_external_comm (comm) call MPI_reduce (func%n_calls, root_n_calls, 1, MPI_INTEGER, & MPI_SUM, 0, comm) if (self%request%is_master ()) then func%n_calls = root_n_calls else call func%reset_n_calls () end if end subroutine reduce_func_calls @ @ Prepeare current integration's iteration. Prepare iteration, i.e. provide weights and grids to function object. Gfortran 7/8/9 bug, only for the MPI version, has to remain in the main module: <>= procedure, private :: prepare_integrate_iteration => & vamp2_prepare_integrate_iteration <>= subroutine vamp2_prepare_integrate_iteration (self, func) class(vamp2_t), intent(inout) :: self class(vamp2_func_t), intent(inout) :: func <> call fill_func_with_weights_and_grids (func) contains subroutine fill_func_with_weights_and_grids (func) class(vamp2_func_t), intent(inout) :: func integer :: ch do ch = 1, self%config%n_channel func%wi(ch) = self%weight(ch) !! \todo Use pointers instead of a deep copy. func%grids(ch) = self%integrator(ch)%get_grid () end do end subroutine fill_func_with_weights_and_grids <> end subroutine vamp2_prepare_integrate_iteration @ %def vamp2_prepare_integrate_iteration <>= @ <>= @ <>= if (.not. allocated (self%request)) then call msg_bug ("VAMP2: prepare integration iteration failed: unallocated request.") end if call broadcast_weights_and_grids () select type (req => self%request) type is (request_simple_t) call req%update (self%integrator%is_parallelizable ()) call init_all_handler (req) call call_all_handler (req) !! Add all handlers, call all handlers. type is (request_caller_t) if (req%is_master ()) then call req%update_balancer (self%weight, self%integrator%is_parallelizable ()) call init_all_handler (req) else call self%request%reset () end if class default call msg_bug ("VAMP2: prepare integration iteration failed: unknown request type.") end select @ <>= subroutine broadcast_weights_and_grids () type(vegas_grid_t) :: grid type(MPI_COMM) :: comm integer :: ch call self%request%get_external_comm (comm) call MPI_BCAST (self%weight, self%config%n_channel, & MPI_DOUBLE_PRECISION, 0, comm) do ch = 1, self%config%n_channel grid = self%integrator(ch)%get_grid () call grid%broadcast (comm) call self%integrator(ch)%set_grid (grid) end do call self%set_calls (self%config%n_calls) end subroutine broadcast_weights_and_grids subroutine init_all_handler (req) class(request_base_t), intent(inout) :: req class(request_handler_t), pointer :: vegas_result_handler integer :: ch !! The master worker needs always all handler (callback objects) !! in order to perform the communication to the client handler (callbacks). if (.not. req%is_master ()) return do ch = 1, self%config%n_channel call self%integrator(ch)%allocate_handler (& handler_id = ch,& handler = vegas_result_handler) call req%add_handler (ch, vegas_result_handler) end do end subroutine init_all_handler subroutine call_all_handler (req) class(request_base_t), intent(inout) :: req integer :: ch if (.not. req%is_master ()) return do ch = 1, self%config%n_channel select type (req) type is (request_simple_t) call req%call_handler (handler_id = ch, & source_rank = req%get_request_master (ch)) end select end do end subroutine call_all_handler @ @ Compute the result and efficiency of the current status of the integrator. <>= procedure, private :: compute_result_and_efficiency => & vamp2_compute_result_and_efficiency <>= module subroutine vamp2_compute_result_and_efficiency (self) class(vamp2_t), intent(inout) :: self end subroutine vamp2_compute_result_and_efficiency <>= module subroutine vamp2_compute_result_and_efficiency (self) class(vamp2_t), intent(inout) :: self real(default) :: total_integral, total_variance real(default) :: max_abs_f_pos, max_abs_f_neg, & sum_abs_f_pos, sum_abs_f_neg call compute_integral_and_variance (total_integral, total_variance) call self%result%update (total_integral, total_variance) call compute_efficiency (max_pos = max_abs_f_pos, max_neg = max_abs_f_neg, & sum_pos = sum_abs_f_pos, sum_neg = sum_abs_f_neg) !! Do not average of number of calls, we have already averaged the efficiencies of all channels. call self%result%update_efficiency (n_calls = 1, & max_pos = max_abs_f_pos, max_neg = max_abs_f_neg, & sum_pos = sum_abs_f_pos, sum_neg = sum_abs_f_neg) contains subroutine compute_integral_and_variance (integral, variance) real(default), intent(out) :: integral, variance real(default) :: sq_integral integral = dot_product (self%weight, self%integrator%get_integral ()) sq_integral = dot_product (self%weight, self%integrator%get_integral ()**2) variance = self%config%n_calls * dot_product (self%weight**2, self%integrator%get_variance ()) variance = sqrt (variance + sq_integral) variance = 1._default / self%config%n_calls * & & (variance + integral) * (variance - integral) end subroutine compute_integral_and_variance !> We compute the weight-averaged sum and maximum of the channel (integration) weights \f$w_{i,c}\f$. !! !! The averaged integration weight and maximum are !! \f[ !! \langle w \rangle = \sum_i \alpha_i \frac{\sum_j w_{i, j}}{N_i}, !! \f] !! \f[ !! \langle \max w \rangle = \sum_i \alpha_i |\max_j w_{i, j}|. !! \f] subroutine compute_efficiency (max_pos, max_neg, & sum_pos, sum_neg) real(default), intent(out) :: max_pos, max_neg real(default), intent(out) :: sum_pos, sum_neg max_abs_f_pos = dot_product (self%weight, self%integrator%get_max_abs_f_pos ()) max_abs_f_neg = dot_product (self%weight, self%integrator%get_max_abs_f_neg ()) sum_abs_f_pos = dot_product (self%weight, & self%integrator%get_sum_abs_f_pos () / self%integrator%get_calls ()) sum_abs_f_neg = dot_product (self%weight, & self%integrator%get_sum_abs_f_neg () / self%integrator%get_calls ()) end subroutine compute_efficiency end subroutine vamp2_compute_result_and_efficiency @ %def vamp2_compute_result_and_efficiency -@ +@ Generate event from multi-channel weight $w(x) = f(x) / g(x)$. We select a channel using the a-priori weights and $f_{i}^{\text{max}}$, to flatten possible unbalanced channel weight(s). An additional rescale factor [[opt_event_rescale]] is applied to [[f_max]], iff set. <>= procedure, public :: generate_weighted => vamp2_generate_weighted_event <>= module subroutine vamp2_generate_weighted_event (self, func, rng, x) class(vamp2_t), intent(inout) :: self class(vamp2_func_t), intent(inout) :: func class(rng_t), intent(inout) :: rng real(default), dimension(self%config%n_dim), intent(out) :: x end subroutine vamp2_generate_weighted_event <>= module subroutine vamp2_generate_weighted_event (self, func, rng, x) class(vamp2_t), intent(inout) :: self class(vamp2_func_t), intent(inout) :: func class(rng_t), intent(inout) :: rng real(default), dimension(self%config%n_dim), intent(out) :: x integer :: ch, i real(default) :: r if (.not. self%event_prepared) then call prepare_event () + else + if (.not. allocated (func%grids)) then + call prepare_event () + else + if (any ([(.not. allocated (func%grids(i)%xi),i=1,size(func%grids))])) then + call prepare_event () + end if + end if end if call rng%generate (r) nchannel: do ch = 1, self%config%n_channel r = r - self%event_weight(ch) if (r <= 0._default) exit nchannel end do nchannel ch = min (ch, self%config%n_channel) call func%set_channel (ch) call self%integrator(ch)%generate_weighted (func, rng, x) ! Norm weight by f_max, hidden in event_weight(ch), else by 1 self%result%evt_weight = self%integrator(ch)%get_evt_weight () & * self%weight(ch) / self%event_weight(ch) contains <> end subroutine vamp2_generate_weighted_event @ %def vamp2_generate_weighted_event @ Generate unweighted events. After selecting a channel $ch$ by the inversion method using a random number $r \in [0, 1]$ \begin{align} F^{-1}(r) := \operatorname{inf} \{ c \in \{1, \dots, N_c\} | F(c) \geq r \}, F(c) = \sum_{c^\prime \leq c} \alpha_c^\prime, \end{align} we try for an event from the previously selected channel. If the event is rejected, we also reject the selected channel. The inversion method is implemented as a loop over the channel weights \(\alpha_i\) until \(\sum_{c}^{c^prime} \alpha_c - r \leq 0\), the last value of the loop index [[ch]] is then \(c^\prime\). <>= procedure, public :: generate_unweighted => & vamp2_generate_unweighted_event <>= module subroutine vamp2_generate_unweighted_event (self, func, rng, & x, opt_event_rescale) class(vamp2_t), intent(inout) :: self class(vamp2_func_t), intent(inout) :: func class(rng_t), intent(inout) :: rng real(default), dimension(self%config%n_dim), intent(out) :: x real(default), intent(in), optional :: opt_event_rescale end subroutine vamp2_generate_unweighted_event <>= module subroutine vamp2_generate_unweighted_event (self, func, rng, & x, opt_event_rescale) class(vamp2_t), intent(inout) :: self class(vamp2_func_t), intent(inout) :: func class(rng_t), intent(inout) :: rng real(default), dimension(self%config%n_dim), intent(out) :: x real(default), intent(in), optional :: opt_event_rescale integer :: ch, i real(default) :: r, max_abs_f, event_rescale event_rescale = 1._default if (present (opt_event_rescale)) then event_rescale = opt_event_rescale end if if (.not. self%event_prepared) then call prepare_event () + else + if (.not. allocated (func%grids)) then + call prepare_event () + else + if (any ([(.not. allocated (func%grids(i)%xi),i=1,size(func%grids))])) then + call prepare_event () + end if + end if end if generate: do call rng%generate (r) nchannel: do ch = 1, self%config%n_channel r = r - self%event_weight(ch) if (r <= 0._default) exit nchannel end do nchannel ch = min (ch, self%config%n_channel) call func%set_channel (ch) call self%integrator(ch)%generate_weighted (func, rng, x) self%result%evt_weight = self%integrator(ch)%get_evt_weight () - max_abs_f = merge ( & - self%integrator(ch)%get_max_abs_f_pos (), & - self%integrator(ch)%get_max_abs_f_neg (), & - self%result%evt_weight > 0.) + max_abs_f = self%integrator(ch)%get_max_abs_f () self%result%evt_weight_excess = 0._default - if (self%result%evt_weight > max_abs_f) then - self%result%evt_weight_excess = self%result%evt_weight / max_abs_f - 1._default + if (abs(self%result%evt_weight) > max_abs_f) then + self%result%evt_weight_excess = abs(self%result%evt_weight) / max_abs_f - 1._default exit generate end if call rng%generate (r) ! Do not use division, because max_abs_f could be zero. if (event_rescale * max_abs_f * r <= abs(self%result%evt_weight)) then exit generate end if end do generate contains <> end subroutine vamp2_generate_unweighted_event @ %def vamp2_generate_event Prepare event generation. We have to set the channel weights and the grids for the integrand's object. We use an ansatz proposed by T. Ohl in the original VAMP code where we do not have to accept on \begin{equation*} \frac{w_i(x)}{\sum_i \alpha_i \operatorname*{max}_{x} w_i(x)}, \end{equation*} after we have selected a channel by the weights $\alpha_i$. But rather, we use a more efficient way where we rescale the channel weights $\alpha_i$ \begin{equation*} \alpha_i \rightarrow \alpha_i \frac{\operatorname*{max}_x w_i(x)}{\sum_i \alpha_i \operatorname*{max}_{x} w_i(x)}. \end{equation*} The overall magic is to insert a "1" and to move the uneasy part into the channel selection, such that we can generate events likewise in the single channel mode. We generate an unweighted event by \begin{equation*} \frac{w_i(x)}{\operatorname*{max}_{x} w_i{x}}, \end{equation*} after we have selected a channel by the rescaled event channel weights. The overall normalization $\operatorname*{max}_{i, x}$ is not needed because we normalize the event channel weights to one and therefore the overall normalization cancels. <>= subroutine prepare_event () integer :: i self%event_prepared = .false. do i = 1, self%config%n_channel func%wi(i) = self%weight(i) func%grids(i) = self%integrator(i)%get_grid () end do if (any (self%integrator%get_max_abs_f () > 0)) then self%event_weight = self%weight * self%integrator%get_max_abs_f () else self%event_weight = self%weight end if self%event_weight = self%event_weight / sum (self%event_weight) self%event_prepared = .true. end subroutine prepare_event @ %def prepare_event @ Write grids to unit. <>= character(len=*), parameter, private :: & descr_fmt = "(1X,A)", & integer_fmt = "(1X,A18,1X,I15)", & integer_array_fmt = "(1X,I18,1X,I15)", & logical_fmt = "(1X,A18,1X,L1)", & double_fmt = "(1X,A18,1X,E24.16E4)", & double_array_fmt = "(1X,I18,1X,E24.16E4)", & double_array_pac_fmt = "(1X,I18,1X,E16.8E4)", & double_array2_fmt = "(1X,2(1X,I8),1X,E24.16E4)", & double_array2_pac_fmt = "(1X,2(1X,I8),1X,E16.8E4)" @ %def descr_fmt integer_fmt integer_array_fmt logical_fmt @ %def double_fmt double_array_fmt double_array2_fmt <>= procedure, public :: write_grids => vamp2_write_grids <>= module subroutine vamp2_write_grids (self, unit) class(vamp2_t), intent(in) :: self integer, intent(in), optional :: unit end subroutine vamp2_write_grids <>= module subroutine vamp2_write_grids (self, unit) class(vamp2_t), intent(in) :: self integer, intent(in), optional :: unit integer :: u integer :: ch u = given_output_unit (unit) write (u, descr_fmt) "begin type(vamp2_t)" write (u, integer_fmt) "n_channel =", self%config%n_channel write (u, integer_fmt) "n_dim =", self%config%n_dim write (u, integer_fmt) "n_calls_min_ch =", self%config%n_calls_min_per_channel write (u, integer_fmt) "n_calls_thres =", self%config%n_calls_threshold write (u, integer_fmt) "n_chains =", self%config%n_chains write (u, logical_fmt) "stratified =", self%config%stratified write (u, double_fmt) "alpha =", self%config%alpha write (u, double_fmt) "beta =", self%config%beta write (u, integer_fmt) "n_bins_max =", self%config%n_bins_max write (u, integer_fmt) "iterations =", self%config%iterations write (u, integer_fmt) "n_calls =", self%config%n_calls write (u, integer_fmt) "it_start =", self%result%it_start write (u, integer_fmt) "it_num =", self%result%it_num write (u, integer_fmt) "samples =", self%result%samples write (u, double_fmt) "sum_int_wgtd =", self%result%sum_int_wgtd write (u, double_fmt) "sum_wgts =", self%result%sum_wgts write (u, double_fmt) "sum_chi =", self%result%sum_chi write (u, double_fmt) "chi2 =", self%result%chi2 write (u, double_fmt) "efficiency =", self%result%efficiency write (u, double_fmt) "efficiency_pos =", self%result%efficiency_pos write (u, double_fmt) "efficiency_neg =", self%result%efficiency_neg write (u, double_fmt) "max_abs_f =", self%result%max_abs_f write (u, double_fmt) "max_abs_f_pos =", self%result%max_abs_f_pos write (u, double_fmt) "max_abs_f_neg =", self%result%max_abs_f_neg write (u, double_fmt) "result =", self%result%result write (u, double_fmt) "std =", self%result%std write (u, descr_fmt) "begin weight" do ch = 1, self%config%n_channel write (u, double_array_fmt) ch, self%weight(ch) end do write (u, descr_fmt) "end weight" if (self%config%n_chains > 0) then write (u, descr_fmt) "begin chain" do ch = 1, self%config%n_channel write (u, integer_array_fmt) ch, self%chain(ch) end do write (u, descr_fmt) "end chain" end if write (u, descr_fmt) "begin integrator" do ch = 1, self%config%n_channel call self%integrator(ch)%write_grid (unit) end do write (u, descr_fmt) "end integrator" write (u, descr_fmt) "end type(vamp2_t)" end subroutine vamp2_write_grids @ %def vamp2_write_grids @ Read grids from unit. <>= procedure, public :: read_grids => vamp2_read_grids <>= module subroutine vamp2_read_grids (self, unit) class(vamp2_t), intent(out) :: self integer, intent(in), optional :: unit end subroutine vamp2_read_grids <>= module subroutine vamp2_read_grids (self, unit) class(vamp2_t), intent(out) :: self integer, intent(in), optional :: unit integer :: u integer :: ibuffer, jbuffer, ch character(len=80) :: buffer read (unit, descr_fmt) buffer read (unit, integer_fmt) buffer, ibuffer read (unit, integer_fmt) buffer, jbuffer select type (self) type is (vamp2_t) self = vamp2_t (n_channel = ibuffer, n_dim = jbuffer) end select read (unit, integer_fmt) buffer, self%config%n_calls_min_per_channel read (unit, integer_fmt) buffer, self%config%n_calls_threshold read (unit, integer_fmt) buffer, self%config%n_chains read (unit, logical_fmt) buffer, self%config%stratified read (unit, double_fmt) buffer, self%config%alpha read (unit, double_fmt) buffer, self%config%beta read (unit, integer_fmt) buffer, self%config%n_bins_max read (unit, integer_fmt) buffer, self%config%iterations read (unit, integer_fmt) buffer, self%config%n_calls read (unit, integer_fmt) buffer, self%result%it_start read (unit, integer_fmt) buffer, self%result%it_num read (unit, integer_fmt) buffer, self%result%samples read (unit, double_fmt) buffer, self%result%sum_int_wgtd read (unit, double_fmt) buffer, self%result%sum_wgts read (unit, double_fmt) buffer, self%result%sum_chi read (unit, double_fmt) buffer, self%result%chi2 read (unit, double_fmt) buffer, self%result%efficiency read (unit, double_fmt) buffer, self%result%efficiency_pos read (unit, double_fmt) buffer, self%result%efficiency_neg read (unit, double_fmt) buffer, self%result%max_abs_f read (unit, double_fmt) buffer, self%result%max_abs_f_pos read (unit, double_fmt) buffer, self%result%max_abs_f_neg read (unit, double_fmt) buffer, self%result%result read (unit, double_fmt) buffer, self%result%std read (unit, descr_fmt) buffer do ch = 1, self%config%n_channel read (unit, double_array_fmt) ibuffer, self%weight(ch) end do read (unit, descr_fmt) buffer if (self%config%n_chains > 0) then read (unit, descr_fmt) buffer do ch = 1, self%config%n_channel read (unit, integer_array_fmt) ibuffer, self%chain(ch) end do read (unit, descr_fmt) buffer end if read (unit, descr_fmt) buffer do ch = 1, self%config%n_channel call self%integrator(ch)%read_grid (unit) end do read (unit, descr_fmt) buffer read (unit, descr_fmt) buffer end subroutine vamp2_read_grids @ %def vamp2_read_grids @ Read and write grids from an unformatted file. <>= procedure :: write_binary_grids => vamp2_write_binary_grids procedure :: read_binary_grids => vamp2_read_binary_grids <>= module subroutine vamp2_write_binary_grids (self, unit) class(vamp2_t), intent(in) :: self integer, intent(in) :: unit end subroutine vamp2_write_binary_grids module subroutine vamp2_read_binary_grids (self, unit) class(vamp2_t), intent(out) :: self integer, intent(in) :: unit end subroutine vamp2_read_binary_grids <>= module subroutine vamp2_write_binary_grids (self, unit) class(vamp2_t), intent(in) :: self integer, intent(in) :: unit integer :: ch write (unit) write (unit) self%config%n_channel write (unit) self%config%n_dim write (unit) self%config%n_calls_min_per_channel write (unit) self%config%n_calls_threshold write (unit) self%config%n_chains write (unit) self%config%stratified write (unit) self%config%alpha write (unit) self%config%beta write (unit) self%config%n_bins_max write (unit) self%config%iterations write (unit) self%config%n_calls write (unit) self%result%it_start write (unit) self%result%it_num write (unit) self%result%samples write (unit) self%result%sum_int_wgtd write (unit) self%result%sum_wgts write (unit) self%result%sum_chi write (unit) self%result%chi2 write (unit) self%result%efficiency write (unit) self%result%efficiency_pos write (unit) self%result%efficiency_neg write (unit) self%result%max_abs_f write (unit) self%result%max_abs_f_pos write (unit) self%result%max_abs_f_neg write (unit) self%result%result write (unit) self%result%std do ch = 1, self%config%n_channel write (unit) ch, self%weight(ch) end do if (self%config%n_chains > 0) then do ch = 1, self%config%n_channel write (unit) ch, self%chain(ch) end do end if do ch = 1, self%config%n_channel call self%integrator(ch)%write_binary_grid (unit) end do end subroutine vamp2_write_binary_grids module subroutine vamp2_read_binary_grids (self, unit) class(vamp2_t), intent(out) :: self integer, intent(in) :: unit integer :: ch, ibuffer, jbuffer read (unit) read (unit) ibuffer read (unit) jbuffer select type (self) type is (vamp2_t) self = vamp2_t (n_channel = ibuffer, n_dim = jbuffer) end select read (unit) self%config%n_calls_min_per_channel read (unit) self%config%n_calls_threshold read (unit) self%config%n_chains read (unit) self%config%stratified read (unit) self%config%alpha read (unit) self%config%beta read (unit) self%config%n_bins_max read (unit) self%config%iterations read (unit) self%config%n_calls read (unit) self%result%it_start read (unit) self%result%it_num read (unit) self%result%samples read (unit) self%result%sum_int_wgtd read (unit) self%result%sum_wgts read (unit) self%result%sum_chi read (unit) self%result%chi2 read (unit) self%result%efficiency read (unit) self%result%efficiency_pos read (unit) self%result%efficiency_neg read (unit) self%result%max_abs_f read (unit) self%result%max_abs_f_pos read (unit) self%result%max_abs_f_neg read (unit) self%result%result read (unit) self%result%std do ch = 1, self%config%n_channel read (unit) ibuffer, self%weight(ch) end do if (self%config%n_chains > 0) then do ch = 1, self%config%n_channel read (unit) ibuffer, self%chain(ch) end do end if do ch = 1, self%config%n_channel call self%integrator(ch)%read_binary_grid (unit) end do end subroutine vamp2_read_binary_grids @ %def vamp2_write_binary_grids, vamp2_read_binary_grids @ \section{Unit tests} \label{sec:unit-tests} Test module, followed by the corresponding implementation module. <<[[vamp2_ut.f90]]>>= <> module vamp2_ut use unit_tests use vamp2_uti <> <> contains <> end module vamp2_ut @ %def vamp2_ut @ <<[[vamp2_uti.f90]]>>= <> module vamp2_uti <> use io_units use constants, only: pi use numeric_utils, only: nearly_equal use format_defs, only: FMT_12 use rng_base use rng_stream use vegas, only: vegas_func_t, vegas_grid_t, operator(==) use vamp2 <> <> <> contains <> end module vamp2_uti @ %def vamp2_uti @ API: driver for the unit tests below. <>= public :: vamp2_test <>= subroutine vamp2_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine vamp2_test @ %def vamp2_test @ \subsubsection{Test function} \label{sec:test-function} We use the example from the Monte Carlo Examples of the GSL library \begin{equation} I = \int_{-pi}^{+pi} {dk_x/(2 pi)} \int_{-pi}^{+pi} {dk_y/(2 pi)} \int_{-pi}^{+pi} {dk_z/(2 pi)} 1 / (1 - cos(k_x)cos(k_y)cos(k_z)). \end{equation} The integral is reduced to region (0,0,0) $\rightarrow$ ($\pi$, $\pi$, $\pi$) and multiplied by 8. <>= type, extends (vamp2_func_t) :: vamp2_test_func_t ! contains <> end type vamp2_test_func_t @ %def vegas_test_func_t @ <>= procedure, public :: evaluate_maps => vamp2_test_func_evaluate_maps <>= subroutine vamp2_test_func_evaluate_maps (self, x) class(vamp2_test_func_t), intent(inout) :: self real(default), dimension(:), intent(in) :: x self%xi(:, 1) = x self%det(1) = 1 self%valid_x = .true. end subroutine vamp2_test_func_evaluate_maps @ %def vamp2_test_func_evaluate_maps @ Evaluate the integrand. <>= procedure, public :: evaluate_func => vamp2_test_func_evaluate <>= real(default) function vamp2_test_func_evaluate (self, x) result (f) class(vamp2_test_func_t), intent(in) :: self real(default), dimension(:), intent(in) :: x f = 1.0 / (pi**3) f = f / ( 1.0 - cos (x(1)) * cos (x(2)) * cos (x(3))) end function vamp2_test_func_evaluate @ %def vamp2_test_func_evaluate @ The second test function implements \begin{equation} f(\vec{x}) = 4 \sin^{2}(\pi x_{1})\sin^{2}(\pi x_{2}) + 2\sin^2(\pi v), \end{equation} where \begin{align} x = u^{v} & y = u^{1 - v} \\ u = xy & v = \frac{1}{2} \left( 1 + \frac{\log(x/y}{\log(xy)} \right). \end{align} The jacobian is $\frac{\partial (x, y)}{\partial (u, v)}$. <>= type, extends(vamp2_func_t) :: vamp2_test_func_2_t ! contains <> end type vamp2_test_func_2_t @ %def vamp2_test_func_2_t @ Evaluate maps. <>= procedure :: evaluate_maps => vamp2_test_func_2_evaluate_maps <>= subroutine vamp2_test_func_2_evaluate_maps (self, x) class(vamp2_test_func_2_t), intent(inout) :: self real(default), dimension(:), intent(in) :: x select case (self%current_channel) case (1) self%xi(:, 1) = x self%xi(1, 2) = x(1) * x(2) self%xi(2, 2) = 0.5 * ( 1. + log(x(1) / x(2)) / log(x(1) * x(2))) case (2) self%xi(1, 1) = x(1)**x(2) self%xi(2, 1) = x(1)**(1. - x(2)) self%xi(:, 2) = x end select self%det(1) = 1. self%det(2) = abs (log(self%xi(1, 2))) self%valid_x = .true. end subroutine vamp2_test_func_2_evaluate_maps @ %def vamp2_test_func_2_evaluate_maps @ Evaluate func. <>= procedure :: evaluate_func => vamp2_test_func_2_evaluate_func <>= real(default) function vamp2_test_func_2_evaluate_func (self, x) result (f) class(vamp2_test_func_2_t), intent(in) :: self real(default), dimension(:), intent(in) :: x f = 4. * sin(pi * self%xi(1, 1))**2 * sin(pi * self%xi(2, 1))**2 & + 2. * sin(pi * self%xi(2, 2))**2 end function vamp2_test_func_2_evaluate_func @ %def vamp2_test_func_2_evaluate_func @ The third test function implements \begin{equation} f(\vec{x}) = 5 x_{1}^4 + 5 (1 - x_{1})^4, \end{equation} where \begin{equation} x_1 = u^{1 / 5} \quad \vee \quad x_1 = 1 - v^{1 / 5} \end{equation} The jacobians are $\frac{\partial x_1}{\partial u} = \frac{1}{5} u^{-\frac{4}{5}}$ and $\frac{\partial x_1}{\partial v} = \frac{1}{5} v^{-\frac{4}{5}}$. <>= type, extends(vamp2_func_t) :: vamp2_test_func_3_t ! contains <> end type vamp2_test_func_3_t @ %def vamp2_test_func_3_t @ Evaluate maps. <>= procedure :: evaluate_maps => vamp2_test_func_3_evaluate_maps <>= subroutine vamp2_test_func_3_evaluate_maps (self, x) class(vamp2_test_func_3_t), intent(inout) :: self real(default), dimension(:), intent(in) :: x real(default) :: u, v, xx select case (self%current_channel) case (1) u = x(1) xx = u**0.2_default v = (1 - xx)**5._default case (2) v = x(1) xx = 1 - v**0.2_default u = xx**5._default end select self%det(1) = 0.2_default * u**(-0.8_default) self%det(2) = 0.2_default * v**(-0.8_default) self%xi(:, 1) = [u] self%xi(:, 2) = [v] self%valid_x = .true. end subroutine vamp2_test_func_3_evaluate_maps @ %def vamp2_test_func_3_evaluate_maps @ Evaluate func. <>= procedure :: evaluate_func => vamp2_test_func_3_evaluate_func <>= real(default) function vamp2_test_func_3_evaluate_func (self, x) result (f) class(vamp2_test_func_3_t), intent(in) :: self real(default), dimension(:), intent(in) :: x real(default) :: xx select case (self%current_channel) case (1) xx = x(1)**0.2_default case (2) xx = 1 - x(1)**0.2_default end select f = 5 * xx**4 + 5 * (1 - xx)**4 end function vamp2_test_func_3_evaluate_func @ %def vamp2_test_func_3_evaluate_func @ \subsubsection{MC Integrator check} \label{sec:mc-integrator-check} We reproduce the first test case of VEGAS. Initialise the VAMP2 MC integrator and call to [[vamp2_init_grid]] for the initialisation of the grid. <>= call test (vamp2_1, "vamp2_1", "VAMP2 initialisation and& & grid preparation", u, results) <>= public :: vamp2_1 <>= subroutine vamp2_1 (u) integer, intent(in) :: u type(vamp2_t) :: mc_integrator class(rng_t), allocatable :: rng class(vamp2_func_t), allocatable :: func real(default), dimension(3), parameter :: x_lower = 0., & x_upper = pi real(default) :: result, abserr write (u, "(A)") "* Test output: vamp2_1" write (u, "(A)") "* Purpose: initialise the VAMP2 MC integrator and the grid" write (u, "(A)") write (u, "(A)") "* Initialise random number generator (default seed)" write (u, "(A)") allocate (rng_stream_t :: rng) call rng%init () call rng%write (u) write (u, "(A)") write (u, "(A)") "* Initialise MC integrator with n_channel = 1 and n_dim = 3" write (u, "(A)") allocate (vamp2_test_func_t :: func) call func%init (n_dim = 3, n_channel = 1) mc_integrator = vamp2_t (1, 3) call mc_integrator%write (u) write (u, "(A)") write (u, "(A)") "* Initialise grid with n_calls = 10000" write (u, "(A)") call mc_integrator%set_limits (x_lower, x_upper) call mc_integrator%set_calls (10000) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 10000 (Adaptation)" write (u, "(A)") call mc_integrator%integrate (func, rng, 3, result=result, abserr=abserr) write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ")") "Result: ", result, " +/- ", abserr write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 2000 (Precision)" write (u, "(A)") call mc_integrator%set_calls (2000) call mc_integrator%integrate (func, rng, 3, result=result, abserr=abserr) write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ")") "Result: ", result, " +/- ", abserr write (u, "(A)") write (u, "(A)") "* Cleanup" call mc_integrator%final () call rng%final () deallocate (rng) end subroutine vamp2_1 @ %def vamp2_1 @ Integrate a function with two-dimensional argument and two channels. <>= call test (vamp2_2, "vamp2_2", "VAMP2 intgeration of two-dimensional & & function with two channels", u, results) <>= public :: vamp2_2 <>= subroutine vamp2_2 (u) integer, intent(in) :: u type(vamp2_t) :: mc_integrator class(rng_t), allocatable :: rng class(vamp2_func_t), allocatable :: func real(default), dimension(2), parameter :: x_lower = 0., & x_upper = 1. real(default) :: result, abserr write (u, "(A)") "* Test output: vamp2_2" write (u, "(A)") "* Purpose: intgeration of two-dimensional & & function with two channels" write (u, "(A)") write (u, "(A)") "* Initialise random number generator (default seed)" write (u, "(A)") allocate (rng_stream_t :: rng) call rng%init () call rng%write (u) write (u, "(A)") write (u, "(A)") "* Initialise MC integrator with n_channel = 1 and n_dim = 3" write (u, "(A)") allocate (vamp2_test_func_2_t :: func) call func%init (n_dim = 2, n_channel = 2) mc_integrator = vamp2_t (2, 2) call mc_integrator%write (u) write (u, "(A)") write (u, "(A)") "* Initialise grid with n_calls = 10000" write (u, "(A)") call mc_integrator%set_limits (x_lower, x_upper) call mc_integrator%set_calls (1000) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 10000 (Adaptation)" write (u, "(A)") call mc_integrator%integrate (func, rng, 3, verbose = .true., result=result, abserr=abserr) write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ")") "Result: ", result, " +/- ", abserr write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 2000 (Precision)" write (u, "(A)") call mc_integrator%set_calls (200) call mc_integrator%integrate (func, rng, 3, verbose = .true., result=result, abserr=abserr) write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ")") "Result: ", result, " +/- ", abserr write (u, "(A)") write (u, "(A)") "* Cleanup" call mc_integrator%final () call rng%final () deallocate (rng) end subroutine vamp2_2 @ %def vamp2_2 @ Integrate a function with two-dimensional argument and two channels. <>= call test (vamp2_3, "vamp2_3", "VAMP2 intgeration of two-dimensional & & function with two channels", u, results) <>= public :: vamp2_3 <>= subroutine vamp2_3 (u) integer, intent(in) :: u type(vamp2_t) :: mc_integrator class(rng_t), allocatable :: rng class(vamp2_func_t), allocatable :: func real(default), dimension(2), parameter :: x_lower = 0., & x_upper = 1. real(default) :: result, abserr integer :: unit write (u, "(A)") "* Test output: vamp2_3" write (u, "(A)") "* Purpose: intgeration of two-dimensional & & function with two channels" write (u, "(A)") write (u, "(A)") "* Initialise random number generator (default seed)" write (u, "(A)") allocate (rng_stream_t :: rng) call rng%init () call rng%write (u) write (u, "(A)") write (u, "(A)") "* Initialise MC integrator with n_channel = 1 and n_dim = 3" write (u, "(A)") allocate (vamp2_test_func_2_t :: func) call func%init (n_dim = 2, n_channel = 2) mc_integrator = vamp2_t (2, 2) call mc_integrator%write (u) write (u, "(A)") write (u, "(A)") "* Initialise grid with n_calls = 20000" write (u, "(A)") call mc_integrator%set_limits (x_lower, x_upper) call mc_integrator%set_calls (20000) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 20000 (Adaptation)" write (u, "(A)") call mc_integrator%integrate (func, rng, 3, result=result, abserr=abserr) write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ")") "Result: ", result, " +/- ", abserr write (u, "(A)") write (u, "(A)") "* Write grid to file vamp2_3.grids" write (u, "(A)") unit = free_unit () open (unit, file = "vamp2_3.grids", & action = "write", status = "replace") call mc_integrator%write_grids (unit) close (unit) write (u, "(A)") write (u, "(A)") "* Read grid from file vamp2_3.grids" write (u, "(A)") call mc_integrator%final () unit = free_unit () open (unit, file = "vamp2_3.grids", & action = "read", status = "old") call mc_integrator%read_grids (unit) close (unit) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 5000 (Precision)" write (u, "(A)") call mc_integrator%set_calls (5000) call mc_integrator%integrate (func, rng, 3, result=result, abserr=abserr) write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ")") "Result: ", result, " +/- ", abserr write (u, "(A)") write (u, "(A)") "* Cleanup" call mc_integrator%final () call rng%final () deallocate (rng) end subroutine vamp2_3 @ %def vamp2_3 @ Integrate a function with two-dimensional argument and two channels. Use chained weights, although we average over each weight itself. <>= call test (vamp2_4, "vamp2_4", "VAMP2 intgeration of two-dimensional & & function with two channels with chains", u, results) <>= public :: vamp2_4 <>= subroutine vamp2_4 (u) integer, intent(in) :: u type(vamp2_t) :: mc_integrator class(rng_t), allocatable :: rng class(vamp2_func_t), allocatable :: func real(default), dimension(2), parameter :: x_lower = 0., & x_upper = 1. real(default) :: result, abserr integer :: unit write (u, "(A)") "* Test output: vamp2_4" write (u, "(A)") "* Purpose: intgeration of two-dimensional & & function with two channels with chains" write (u, "(A)") write (u, "(A)") "* Initialise random number generator (default seed)" write (u, "(A)") allocate (rng_stream_t :: rng) call rng%init () call rng%write (u) write (u, "(A)") write (u, "(A)") "* Initialise MC integrator with n_channel = 2 and n_dim = 2" write (u, "(A)") allocate (vamp2_test_func_2_t :: func) call func%init (n_dim = 2, n_channel = 2) mc_integrator = vamp2_t (2, 2) call mc_integrator%write (u) write (u, "(A)") write (u, "(A)") "* Initialise grid with n_calls = 20000 and set chains" write (u, "(A)") call mc_integrator%set_limits (x_lower, x_upper) call mc_integrator%set_calls (20000) call mc_integrator%set_chain (2, [1, 2]) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 10000 (Adaptation)" write (u, "(A)") call mc_integrator%integrate (func, rng, 3, result=result, abserr=abserr) write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ")") "Result: ", result, " +/- ", abserr write (u, "(A)") write (u, "(A)") "* Write grid to file vamp2_4.grids" write (u, "(A)") unit = free_unit () open (unit, file = "vamp2_4.grids", & action = "write", status = "replace") call mc_integrator%write_grids (unit) close (unit) write (u, "(A)") write (u, "(A)") "* Read grid from file vamp2_4.grids" write (u, "(A)") call mc_integrator%final () unit = free_unit () open (unit, file = "vamp2_4.grids", & action = "read", status = "old") call mc_integrator%read_grids (unit) close (unit) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 5000 (Precision)" write (u, "(A)") call mc_integrator%set_calls (5000) call mc_integrator%integrate (func, rng, 3, result=result, abserr=abserr) write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ")") "Result: ", result, " +/- ", abserr write (u, "(A)") write (u, "(A)") "* Cleanup" call mc_integrator%final () call rng%final () deallocate (rng) end subroutine vamp2_4 @ %def vamp2_4 @ <>= call test (vamp2_5, "vamp2_5", "VAMP2 intgeration of two-dimensional & & function with two channels with equivalences", u, results) <>= public :: vamp2_5 <>= subroutine vamp2_5 (u) integer, intent(in) :: u type(vamp2_t) :: mc_integrator class(rng_t), allocatable :: rng class(vamp2_func_t), allocatable :: func real(default), dimension(1), parameter :: x_lower = 0., & x_upper = 1. real(default) :: result, abserr integer :: unit type(vamp2_config_t) :: config type(vamp2_equivalences_t) :: eqv type(vegas_grid_t), dimension(2) :: grid write (u, "(A)") "* Test output: vamp2_5" write (u, "(A)") "* Purpose: intgeration of two-dimensional & & function with two channels with equivalences" write (u, "(A)") write (u, "(A)") "* Initialise random number generator (default seed)" write (u, "(A)") allocate (rng_stream_t :: rng) call rng%init () call rng%write (u) write (u, "(A)") write (u, "(A)") "* Initialise MC integrator with n_channel = 2 and n_dim = 1" write (u, "(A)") allocate (vamp2_test_func_3_t :: func) call func%init (n_dim = 1, n_channel = 2) config%equivalences = .true. mc_integrator = vamp2_t (n_channel = 2, n_dim = 1) call mc_integrator%set_config (config) call mc_integrator%write (u) write (u, "(A)") write (u, "(A)") "* Initialise grid with n_calls = 20000 and set chains" write (u, "(A)") call mc_integrator%set_limits (x_lower, x_upper) call mc_integrator%set_calls (20000) write (u, "(A)") write (u, "(A)") "* Initialise equivalences" write (u, "(A)") eqv = vamp2_equivalences_t (n_eqv = 4, n_channel = 2, n_dim = 1) call eqv%set_equivalence & (i_eqv = 1, dest = 2, src = 1, perm = [1], mode = [VEQ_IDENTITY]) call eqv%set_equivalence & (i_eqv = 2, dest = 1, src = 2, perm = [1], mode = [VEQ_IDENTITY]) call eqv%set_equivalence & (i_eqv = 3, dest = 1, src = 1, perm = [1], mode = [VEQ_IDENTITY]) call eqv%set_equivalence & (i_eqv = 4, dest = 2, src = 2, perm = [1], mode = [VEQ_IDENTITY]) call eqv%write (u) call mc_integrator%set_equivalences (eqv) write (u, "(A)") write (u, "(A)") & "* Integrate with n_it = 3 and n_calls = 10000 (Grid-only Adaptation)" write (u, "(A)") call mc_integrator%integrate (func, rng, 3, & adapt_weights = .false., result=result, abserr=abserr) if (nearly_equal & (result, 2.000_default, rel_smallness = 0.003_default)) then write (u, "(2x,A)") "Result: 2.000 [ok]" else write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ",A)") & "Result: ", result, " +/- ", abserr, " [not ok]" end if write (u, "(A)") write (u, "(A)") "* Compare the grids of both channels" write (u, "(A)") grid(1) = mc_integrator%get_grid(channel = 1) grid(2) = mc_integrator%get_grid(channel = 2) write (u, "(2X,A,1X,L1)") "Equal grids =", (grid(1) == grid(2)) write (u, "(A)") write (u, "(A)") "* Write grid to file vamp2_5.grids" write (u, "(A)") unit = free_unit () open (unit, file = "vamp2_5.grids", & action = "write", status = "replace") call mc_integrator%write_grids (unit) close (unit) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 5000 (Precision)" write (u, "(A)") call mc_integrator%set_calls (5000) call mc_integrator%integrate (func, rng, 3, adapt_weights = .false., & refine_grids = .false., result=result, abserr=abserr) if (nearly_equal & (result, 2.000_default, rel_smallness = 0.003_default)) then write (u, "(2x,A)") "Result: 2.000 [ok]" else write (u, "(2x,A," // FMT_12 // ",A," // FMT_12 // ",A)") & "Result: ", result, " +/- ", abserr, " [not ok]" end if write (u, "(A)") write (u, "(A)") "* Cleanup" call mc_integrator%final () call rng%final () deallocate (rng) end subroutine vamp2_5 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{MPI Request} \begin{description} \item[Request] Direct interface for requests. \item[Balancer] Sublidiary interfaces and types for implementation into [[request]]. \item[Callback] Direct interface for non-blocking communication in callback fashion used in subsidiary in [[request]]. \end{description} \subsection{Request Base} \begin{description} \item[request] Container type for current request, contains handler index and status of request. \item[request group cache] Caching for commnunicator groups, tries to reduce the costly calls to [[MPI_CREATE_COMM_GROUP]]. \item[request base] Base type for request handling, defines procedures and basic request scheme for direct implementation into [[VAMP2]]. \end{description} When a data type has an associated communicator field, it always must duplicate the communicator in order to ensure communication encapsulation. Only in special case (e.g. outside of object communication is required) the parent communicator should be directly used. For example, that is the case for the group cache, as it exports its newly created communicator to the outside of the request library. <<[[request_base.f90]]>>= <> module request_base use balancer_base use request_callback use mpi_f08 !NODEP! <> <> <> <> interface <> end interface end module request_base @ %def request_base @ <<[[request_base_sub.f90]]>>= <> submodule (request_base) request_base_s use io_units use diagnostics implicit none contains <> end submodule request_base_s @ %def request_base_s @ <>= public :: request_t <>= type :: request_t integer :: handler_id = 0 logical :: terminate = .false. logical :: group = .false. logical :: group_master = .false. logical :: callback = .false. type(MPI_COMM) :: comm end type request_t @ %def request_t @ <>= type :: request_group_cache_t private type(MPI_COMM) :: parent_comm type(MPI_GROUP) :: parent_group type(MPI_COMM) :: comm type(MPI_GROUP) :: group integer, dimension(:), allocatable :: rank contains <> end type request_group_cache_t @ %def request_group_cache_t @ Base type for requesting and back calling. A short remark on the semantics of point-to-point communication (as its intended use in this implemenation): MPI is strict regarding the order of the messages (for blocking communication), as those can not overtake each other, p. 41. For non-blocking communication, the standard extends it such that the order depends on "the execution order of the calls that initiate the communication". The non-overtaking requirement is then extended to this definition of -order. +order. Color method for tracking communication? We restrict each slave to a single callback (at once), which can communicate during the next request computation. Before handling the next (current) callback, the former one has to finish (with a wait call on the client-side). On the server-side, we only test on the finishing, reporting a communication -failure. +failure. Furthermore, the implementation has to take care that the order of the communication calls on the master and slave code always matches! Therefore, we need to secure the order of communication calls. First, we let the master initiate all callback communication *before* polling. This fixiates the order. Second, we require that the implementation of the polling honors this order. <>= public :: request_base_t <>= type, abstract :: request_base_t type(MPI_COMM) :: comm type(MPI_COMM) :: external_comm !! communicator for use outside of request, however, just a duplicate of comm. class(balancer_base_t), allocatable :: balancer type(request_group_cache_t) :: cache type(request_handler_manager_t) :: handler contains <> end type request_base_t @ %def request_base_t @ <>= !> The basic idea behind the request mechanism is that each associated worker can request a workload either from a predefined local stack, from local stealing or from a global queue. !! !! We note that it is not necessary to differentiate between master and worker on this level of abstraction. !! Hence, the request interface ignores any notion regarding a possible parallelization concept. abstract interface subroutine request_base_deferred_write (req, unit) import :: request_base_t class(request_base_t), intent(in) :: req integer, intent(in), optional :: unit end subroutine request_base_deferred_write !> Verify if request object has workers. !! !! An implementation shall return if there at least two workers, or otherwisely stated, !! one master and one slave at least, when both are used as computing ranks. logical function request_base_has_workers (req) result (flag) import :: request_base_t class(request_base_t), intent(in) :: req end function request_base_has_workers end interface @ %def request_base_has_workers @ <>= !> Request workload and returns an request_t object. !! !! The request_t object has an associated handler_id and provide several ways !! to indicate whether the execution is to be terminated, or the request has an associated communictor. !! Finally, whether we expect that the handler id will be connected to an callback. !! !! \param[out] request Request container. abstract interface subroutine request_base_request_workload (req, request) import :: request_base_t, request_t class(request_base_t), intent(inout) :: req type(request_t), intent(out) :: request end subroutine request_base_request_workload end interface @ %def request_base_request_workload @ <>= !> Release workload with the information from the request container. !! !! The release procedure may notify the master about the finishing of the workload associated with the handler_id. !! Or, it may just bookkeep whether the workload has finished. !! Additionally, if request%callback was true, it could handle the callback (from client side.) abstract interface subroutine request_base_release_workload (req, request) import :: request_base_t, request_t class(request_base_t), intent(inout) :: req type(request_t), intent(in) :: request end subroutine request_base_release_workload end interface @ %def request_base_release_workload -@ +@ <>= !> Handle associated callback and release workload with the information from the request container. !! !! The procedure must call the associated callback handler using the handler_id. !! Remark: The callback manager is quite squishy regarding a missing handler (silent failure). !! The procedure has to take care whether the callback was actually successful. !! The further release of the workload can then be deferred to the release_workload procedure. !! \param[in] request. abstract interface subroutine request_base_handle_and_release_workload (req, request) import :: request_base_t, request_t class(request_base_t), intent(inout) :: req type(request_t), intent(in) :: request end subroutine request_base_handle_and_release_workload end interface @ %def request_base_handle_and_release_workload @ <>= procedure :: init => request_group_cache_init <>= module subroutine request_group_cache_init (cache, comm) class(request_group_cache_t), intent(inout) :: cache type(MPI_COMM), intent(in) :: comm end subroutine request_group_cache_init <>= module subroutine request_group_cache_init (cache, comm) class(request_group_cache_t), intent(inout) :: cache type(MPI_COMM), intent(in) :: comm call MPI_COMM_DUP (comm, cache%parent_comm) !! Local operation. call MPI_COMM_GROUP (cache%parent_comm, cache%parent_group) cache%group = MPI_GROUP_EMPTY cache%comm = MPI_COMM_NULL end subroutine request_group_cache_init @ %def request_group_cache_init @ <>= procedure :: reset => request_group_cache_reset <>= module subroutine request_group_cache_reset (cache) class(request_group_cache_t), intent(inout) :: cache end subroutine request_group_cache_reset <>= module subroutine request_group_cache_reset (cache) class(request_group_cache_t), intent(inout) :: cache cache%group = MPI_GROUP_EMPTY cache%comm = MPI_COMM_NULL end subroutine request_group_cache_reset @ %def request_group_cache_reset @ <>= procedure :: update => request_group_cache_update <>= module subroutine request_group_cache_update (cache, tag, rank) class(request_group_cache_t), intent(inout) :: cache integer, intent(in) :: tag integer, dimension(:), allocatable, intent(inout) :: rank end subroutine request_group_cache_update <>= module subroutine request_group_cache_update (cache, tag, rank) class(request_group_cache_t), intent(inout) :: cache integer, intent(in) :: tag integer, dimension(:), allocatable, intent(inout) :: rank type(MPI_GROUP) :: group integer :: result, error call move_alloc (rank, cache%rank) call MPI_GROUP_INCL (cache%parent_group, size (cache%rank), cache%rank, group) call MPI_GROUP_COMPARE (cache%group, group, result) if (result /= MPI_IDENT) then cache%group = group if (cache%comm /= MPI_COMM_NULL) call MPI_COMM_FREE (cache%comm) !! Group-local operation. However, time consuming. call MPI_COMM_CREATE_GROUP (cache%parent_comm, cache%group, tag, & cache%comm, error) if (error /= 0) then call msg_bug ("Error occured during communicator creation...") end if ! else ! call msg_message ("CACHE UPDATE: GROUPS ARE (NEARLY) IDENTICAL") end if end subroutine request_group_cache_update @ %def request_group_cache_update @ <>= procedure :: get_comm => request_group_cache_get_comm <>= module subroutine request_group_cache_get_comm (cache, comm) class(request_group_cache_t), intent(in) :: cache type(MPI_COMM), intent(out) :: comm end subroutine request_group_cache_get_comm <>= module subroutine request_group_cache_get_comm (cache, comm) class(request_group_cache_t), intent(in) :: cache type(MPI_COMM), intent(out) :: comm comm = cache%comm end subroutine request_group_cache_get_comm @ %def request_group_cache_get_comm @ <>= procedure :: is_master => request_group_cache_is_master <>= module function request_group_cache_is_master (cache) result (flag) class(request_group_cache_t), intent(in) :: cache integer :: rank, error logical :: flag end function request_group_cache_is_master <>= module function request_group_cache_is_master (cache) result (flag) class(request_group_cache_t), intent(in) :: cache integer :: rank, error logical :: flag call MPI_COMM_RANK (cache%comm, rank, error) if (error /= 0) then call msg_bug ("Error: Could not retrieve group rank.") end if flag = (rank == 0) end function request_group_cache_is_master @ %def request_group_cache_is_master @ <>= procedure :: base_init => request_base_init <>= module subroutine request_base_init (req, comm) class(request_base_t), intent(out) :: req type(MPI_COMM), intent(in) :: comm end subroutine request_base_init <>= !! ================================================= !! request_base_t !! ================================================= !> Initialize request base with parent communicator. !! !! In order to separate the communication between different parts of the request library, !! duplicate the parent communicator using MPI_COMM_DUP, also done by cache and handler objects. !! !! \param[in] comm Parent MPI communicator for overall library. module subroutine request_base_init (req, comm) class(request_base_t), intent(out) :: req type(MPI_COMM), intent(in) :: comm call MPI_COMM_DUP (comm, req%comm) call MPI_COMM_DUP (comm, req%external_comm) call req%cache%init (comm) call req%handler%init (comm) end subroutine request_base_init @ %def request_base_init @ <>= procedure :: base_write => request_base_write procedure(request_base_deferred_write), deferred :: write <>= module subroutine request_base_write (req, unit) class(request_base_t), intent(in) :: req integer, intent(in), optional :: unit end subroutine request_base_write <>= module subroutine request_base_write (req, unit) class(request_base_t), intent(in) :: req integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (allocated (req%balancer)) then call req%balancer%write (u) else write (u, "(A)") "[BALANCER]" write (u, "(A)") "=> Not allocated" end if call req%handler%write (u) end subroutine request_base_write @ %def request_base_write @ <>= procedure :: is_master => request_base_is_master procedure(request_base_has_workers), deferred :: has_workers <>= module function request_base_is_master (req) result (flag) class(request_base_t), intent(in) :: req integer :: rank, ierr logical :: flag end function request_base_is_master <>= !> Check whether current worker is master rank in object communicator. !! !! Do not confuse with a group's master !!! !! Proof: rank == 0 module function request_base_is_master (req) result (flag) class(request_base_t), intent(in) :: req integer :: rank, ierr logical :: flag call MPI_COMM_RANK (req%comm, rank, ierr) if (ierr /= 0) then write (*, "(A,1X,I0)") "MPI Error: request_base_is_master", ierr stop 1 end if flag = (rank == 0) end function request_base_is_master @ %def request_base_is_master @ <>= procedure :: get_external_comm => request_base_get_external_comm <>= module subroutine request_base_get_external_comm (req, comm) class(request_base_t), intent(in) :: req type(MPI_COMM), intent(out) :: comm end subroutine request_base_get_external_comm <>= !> Provide external communicator. !! !! The external communicator is just a duplicate of request%comm, !! in order to provide the same group of workers to external communication, !! however, in a different context, such that communication from outside does not interfere with request. module subroutine request_base_get_external_comm (req, comm) class(request_base_t), intent(in) :: req type(MPI_COMM), intent(out) :: comm comm = req%external_comm end subroutine request_base_get_external_comm @ %def request_base_get_external_comm @ <>= procedure :: add_balancer => request_base_add_balancer <>= module subroutine request_base_add_balancer (req, balancer) class(request_base_t), intent(inout) :: req class(balancer_base_t), allocatable, intent(inout) :: balancer end subroutine request_base_add_balancer <>= !> Add balancer to request. !! !! \param[inout] balancer module subroutine request_base_add_balancer (req, balancer) class(request_base_t), intent(inout) :: req class(balancer_base_t), allocatable, intent(inout) :: balancer if (allocated (req%balancer)) deallocate (req%balancer) call move_alloc (balancer, req%balancer) end subroutine request_base_add_balancer @ %def request_base_add_balancer @ <>= procedure :: add_handler => request_base_add_handler <>= module subroutine request_base_add_handler (req, handler_id, handler) class(request_base_t), intent(inout) :: req integer, intent(in) :: handler_id class(request_handler_t), pointer, intent(in) :: handler end subroutine request_base_add_handler <>= !> Add request handler with handler_id. !! !! \param[in] handler_id !! \param[in] handler Pointer to handler object. module subroutine request_base_add_handler (req, handler_id, handler) class(request_base_t), intent(inout) :: req integer, intent(in) :: handler_id class(request_handler_t), pointer, intent(in) :: handler call req%handler%add (handler_id, handler) end subroutine request_base_add_handler @ %def request_base_add_handler @ <>= procedure :: reset => request_base_reset <>= module subroutine request_base_reset (req, deallocate_balancer) class(request_base_t), intent(inout) :: req logical, intent(in), optional :: deallocate_balancer logical :: flag end subroutine request_base_reset <>= !> Reset request. !! Clear handler manager from associated callbacks, !! deallocate balancer, iff allocated, and reset communicator cache. module subroutine request_base_reset (req, deallocate_balancer) class(request_base_t), intent(inout) :: req logical, intent(in), optional :: deallocate_balancer logical :: flag flag = .false.; if (present (deallocate_balancer)) & flag = deallocate_balancer if (flag .and. allocated (req%balancer)) then deallocate (req%balancer) end if call req%handler%clear () call req%cache%reset () end subroutine request_base_reset @ %def request_base_reset @ <>= procedure :: call_handler => request_base_call_handler <>= module subroutine request_base_call_handler & (req, handler_id, source_rank) class(request_base_t), intent(inout) :: req integer, intent(in) :: handler_id integer, intent(in) :: source_rank end subroutine request_base_call_handler <>= !> Call handler for master communication for handler_id. !! !! \param[in] handler_id The associated key of the callback object. !! \param[in] source_rank The rank of the result's source. module subroutine request_base_call_handler & (req, handler_id, source_rank) class(request_base_t), intent(inout) :: req integer, intent(in) :: handler_id integer, intent(in) :: source_rank call req%handler%callback (handler_id, source_rank) end subroutine request_base_call_handler @ %def request_base_call_handler @ <>= procedure :: call_client_handler => request_base_call_client_handler <>= module subroutine request_base_call_client_handler (req, handler_id) class(request_base_t), intent(inout) :: req integer, intent(in) :: handler_id end subroutine request_base_call_client_handler <>= !> Call handler for slave communication for handler_id. !! !! \param[in] handler_id The associated key of the callback object. module subroutine request_base_call_client_handler (req, handler_id) class(request_base_t), intent(inout) :: req integer, intent(in) :: handler_id call req%handler%client_callback (handler_id, 0) end subroutine request_base_call_client_handler @ %def request_base_call_client_handler @ <>= procedure :: await_handler => request_base_await_handler <>= module subroutine request_base_await_handler (req) class(request_base_t), intent(inout) :: req end subroutine request_base_await_handler <>= !> Wait on all handler in request handler manager to finish communication. module subroutine request_base_await_handler (req) class(request_base_t), intent(inout) :: req call req%handler%waitall () end subroutine request_base_await_handler @ %def request_base_await_handler @ <>= procedure :: barrier => request_base_barrier procedure(request_base_request_workload), deferred :: request_workload procedure(request_base_release_workload), deferred :: release_workload procedure(request_base_handle_and_release_workload), deferred :: handle_and_release_workload <>= module subroutine request_base_barrier (req) class(request_base_t), intent(in) :: req integer :: error end subroutine request_base_barrier <>= module subroutine request_base_barrier (req) class(request_base_t), intent(in) :: req integer :: error call MPI_BARRIER (req%comm, error) if (error /= MPI_SUCCESS) then call msg_fatal ("Request: Error occured during MPI_BARRIER synchronisation.") end if end subroutine request_base_barrier @ %def request_base_barrier @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Request Simple} We implement a local request scheme, without any additional communication, except the callback communication. <<[[request_simple.f90]]>>= <> module request_simple use array_list use balancer_base use balancer_simple use request_base use mpi_f08 !NODEP! <> <> <> interface <> end interface contains <> end module request_simple @ %def request_simple @ <<[[request_simple_sub.f90]]>>= <> submodule (request_simple) request_simple_s use io_units use diagnostics implicit none contains <> end submodule request_simple_s @ %def request_simple_s @ <>= public :: request_simple_t <>= type, extends (request_base_t) :: request_simple_t integer :: n_workers = 0 integer :: n_channels = 0 logical, dimension(:), allocatable :: parallel_grid contains <> end type request_simple_t @ %def request_simple_t @ Gfortran 7/8/9 bug, has to remain in main module: <>= procedure :: init => request_simple_init <>= module subroutine request_simple_init (req, comm, n_channels) class(request_simple_t), intent(out) :: req type(MPI_COMM), intent(in) :: comm integer, intent(in) :: n_channels integer :: n_workers call req%base_init (comm) call MPI_COMM_SIZE (req%comm, req%n_workers) req%n_channels = n_channels allocate (req%parallel_grid (n_channels), source = .false.) call allocate_balancer () contains subroutine allocate_balancer () class(balancer_base_t), allocatable :: balancer allocate (balancer_simple_t :: balancer) select type (balancer) type is (balancer_simple_t) call balancer%init (n_workers = req%n_workers, n_resources = req%n_channels) end select call req%add_balancer (balancer) end subroutine allocate_balancer end subroutine request_simple_init @ %def request_simple_init @ Update number of channels and parallel grids. The simple request object does not utilize the request balancer, as the complexity of the request balancer is not required for the simple approach. The simple approach assigns each worker several channel by a modular mapping from the set of workers $\left\{0,\ldots, N\right\}$ to the set of channels $\left\{1, \ldots , N_c \right\}$. Vetoing on those channel which have a parallel grid (check the definition in [[vegas.f90]]), where all workers are assigned. \begin{equation*} w = \phi(c) = (c - 1) \mod{N}, \text{if not}\; P(c), \text{else}\; \forall w \to c. \end{equation*} The information is stored in a dynamic-sized array list, which is filled, reversed and then used in a stack-like manner keeping track of the unassigned channels. Assigned and finished channels are then moved to the finished stack. <>= procedure :: update => request_simple_update <>= module subroutine request_simple_update (req, parallel_grid) class(request_simple_t), intent(inout) :: req logical, dimension(:), intent(in) :: parallel_grid end subroutine request_simple_update <>= module subroutine request_simple_update (req, parallel_grid) class(request_simple_t), intent(inout) :: req logical, dimension(:), intent(in) :: parallel_grid integer :: me, worker call req%reset () call MPI_COMM_RANK (req%comm, me) worker = SHIFT_RANK_TO_WORKER(me) select type (balancer => req%balancer) type is (balancer_simple_t) call balancer%update_state (worker, parallel_grid) end select req%parallel_grid = parallel_grid end subroutine request_simple_update @ %def request_simple_update @ <>= procedure :: write => request_simple_write <>= module subroutine request_simple_write (req, unit) class(request_simple_t), intent(in) :: req integer, intent(in), optional :: unit end subroutine request_simple_write <>= module subroutine request_simple_write (req, unit) class(request_simple_t), intent(in) :: req integer, intent(in), optional :: unit integer :: u, n_size u = given_output_unit (unit) write (u, "(A)") "[REQUEST_SIMPLE]" write (u, "(A,1X,I0)") "N_CHANNELS", req%n_channels write (u, "(A,1X,I0)") "N_WORKERS", req%n_workers n_size = min (25, req%n_channels) write (u, "(A,25(1X,L1))") "PARALLEL_GRID", req%parallel_grid(:n_size) call req%base_write (u) end subroutine request_simple_write @ %def request_simple_write @ <>= procedure :: has_workers => request_simple_has_workers <>= module function request_simple_has_workers (req) result (flag) class(request_simple_t), intent(in) :: req logical :: flag end function request_simple_has_workers <>= module function request_simple_has_workers (req) result (flag) class(request_simple_t), intent(in) :: req logical :: flag flag = (req%n_workers > 1) end function request_simple_has_workers @ %def request_simple_has_workers @ <>= procedure :: get_request_master => request_simple_get_request_master <>= module function request_simple_get_request_master & (req, channel) result (rank) class(request_simple_t), intent(in) :: req integer, intent(in) :: channel integer :: rank end function request_simple_get_request_master <>= module function request_simple_get_request_master & (req, channel) result (rank) class(request_simple_t), intent(in) :: req integer, intent(in) :: channel integer :: rank if (.not. allocated (req%balancer)) then call msg_bug ("Error: Balancer is not allocated.") end if rank = shift_worker_to_rank (req%balancer%get_resource_master (channel)) !! "Caveat emptor" hits here: !! The balancer returns either a valid worker id or (-1) depending on the associated resource (it must be active...) !! We have to check whether returned worker index is plausible. end function request_simple_get_request_master @ %def request_simple_get_request_master @ <>= !! deferred. procedure :: request_workload => request_simple_request_workload <>= module subroutine request_simple_request_workload (req, request) class(request_simple_t), intent(inout) :: req type(request_t), intent(out) :: request end subroutine request_simple_request_workload <>= !> Request workload. !! !! Depending on parallel_grid, we fill the request object differently. !! First, we do not set commnuicator for .not. parallel_grid (group and group master are set to .false., also). !! And the callback needs to be executed. !! Second, for parallel_grid, we set req%comm to the associated communicator and set group to .true.. !! However, the overall master has the grid's result, therefore, only the master needs to the callback. !! Remark: We can actually intercept the callback for the master to himself; the results are already in the current position. module subroutine request_simple_request_workload (req, request) class(request_simple_t), intent(inout) :: req type(request_t), intent(out) :: request integer :: rank, worker_id call MPI_COMM_RANK (req%comm, rank) worker_id = shift_rank_to_worker (rank) if (.not. req%balancer%is_pending () & .or. .not. req%balancer%is_assignable (worker_id)) then request%terminate = .true. return end if call req%balancer%assign_worker (worker_id, request%handler_id) associate (channel => request%handler_id) if (req%parallel_grid (channel)) then request%comm = req%external_comm request%group = .true. !! The object communicator is master. request%group_master = & (req%get_request_master (channel) == rank) request%callback = req%is_master () else request%comm = req%external_comm request%group = .false. request%group_master = .true. request%callback = .true. end if end associate end subroutine request_simple_request_workload @ %def request_simple_request_workload @ <>= procedure :: release_workload => request_simple_release_workload <>= module subroutine request_simple_release_workload (req, request) class(request_simple_t), intent(inout) :: req type(request_t), intent(in) :: request end subroutine request_simple_release_workload <>= module subroutine request_simple_release_workload (req, request) class(request_simple_t), intent(inout) :: req type(request_t), intent(in) :: request integer :: rank, worker_id call MPI_COMM_RANK (req%comm, rank) worker_id = shift_rank_to_worker (rank) call req%balancer%free_worker (worker_id, request%handler_id) end subroutine request_simple_release_workload @ %def request_simple_release_workload @ <>= procedure :: handle_and_release_workload => & request_simple_handle_and_release_workload <>= module subroutine request_simple_handle_and_release_workload (req, request) class(request_simple_t), intent(inout) :: req type(request_t), intent(in) :: request end subroutine request_simple_handle_and_release_workload <>= module subroutine request_simple_handle_and_release_workload (req, request) class(request_simple_t), intent(inout) :: req type(request_t), intent(in) :: request call req%call_client_handler (request%handler_id) call req%release_workload (request) end subroutine request_simple_handle_and_release_workload @ %def request_simple_handle_and_release_workload @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Request Caller} We implement an global queue approach, requiring permanent communication between a governor and the worker. <<[[request_caller.f90]]>>= <> module request_caller <> use diagnostics use request_base use balancer_base use balancer_channel use request_state use request_callback use mpi_f08 !NODEP! <> <> <> interface <> end interface contains <> end module request_caller @ %def request_caller @ <<[[request_caller_sub.f90]]>>= <> submodule (request_caller) request_caller_s use io_units implicit none contains <> end submodule request_caller_s @ %def request_caller_s @ <>= public :: request_caller_t <>= type, extends (request_base_t):: request_caller_t private integer :: n_channels = 0 integer :: n_workers = 0 type(request_state_t) :: state contains <> end type request_caller_t @ %def request_caller_t @ Gfortran 7/8/9 bug, has to remain in the main module: <>= procedure :: init => request_caller_init <>= subroutine request_caller_init (req, comm, n_channels) class(request_caller_t), intent(out) :: req type(MPI_COMM), intent(in) :: comm integer, intent(in) :: n_channels call req%base_init (comm) call MPI_COMM_SIZE (req%comm, req%n_workers) !! Exclude master rank (0) from set of workers. req%n_workers = req%n_workers - 1 if (.not. req%has_workers ()) then call msg_warning ("Must not handle less than 3 ranks in a master/slave global queue.") call MPI_ABORT (req%comm, 1) end if req%n_channels = n_channels call req%state%init (comm, req%n_workers) if (req%is_master ()) then call allocate_balancer () end if contains subroutine allocate_balancer () class(balancer_base_t), allocatable :: balancer allocate (balancer_channel_t :: balancer) select type (balancer) type is (balancer_channel_t) call balancer%init (n_workers = req%n_workers, n_resources = req%n_channels) end select call req%add_balancer (balancer) end subroutine allocate_balancer end subroutine request_caller_init @ %def request_caller_init @ <>= procedure :: write => request_caller_write <>= module subroutine request_caller_write (req, unit) class(request_caller_t), intent(in) :: req integer, intent(in), optional :: unit end subroutine request_caller_write <>= module subroutine request_caller_write (req, unit) class(request_caller_t), intent(in) :: req integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(A)") "[REQUEST_CALLER]" call req%base_write (u) if (req%is_master ()) & call req%state%write (u) end subroutine request_caller_write @ %def request_caller_write @ <>= procedure :: has_workers => request_caller_has_workers <>= module function request_caller_has_workers (req) result (flag) class(request_caller_t), intent(in) :: req logical :: flag end function request_caller_has_workers <>= module function request_caller_has_workers (req) result (flag) class(request_caller_t), intent(in) :: req logical :: flag !! n_workers excludes the master rank. flag = (req%n_workers > 1) end function request_caller_has_workers @ %def request_caller_has_workers @ <>= procedure :: update_balancer => request_caller_update_balancer <>= module subroutine request_caller_update_balancer (req, weight, parallel_grid) class(request_caller_t), intent(inout) :: req real(default), dimension(:), intent(in) :: weight logical, dimension(:), intent(in) :: parallel_grid end subroutine request_caller_update_balancer <>= module subroutine request_caller_update_balancer (req, weight, parallel_grid) class(request_caller_t), intent(inout) :: req real(default), dimension(:), intent(in) :: weight logical, dimension(:), intent(in) :: parallel_grid !! \note bug if not allocated? if (.not. allocated (req%balancer)) return call req%state%reset () call req%reset () select type (balancer => req%balancer) type is (balancer_channel_t) call balancer%update_state(weight, parallel_grid) end select end subroutine request_caller_update_balancer @ %def request_caller_update_balancer @ <>= procedure :: handle_workload => request_caller_handle_workload <>= module subroutine request_caller_handle_workload (req) class(request_caller_t), intent(inout) :: req end subroutine request_caller_handle_workload <>= module subroutine request_caller_handle_workload (req) class(request_caller_t), intent(inout) :: req integer :: handler, tag, source, worker_id if (.not. allocated (req%balancer)) then call msg_warning ("Request: Error occured, load balancer not allocated.& & Terminate all workers.") !! We postpone to stop the program here so we can terminate all workers gracefully. !! First, we receive their requests, then we overwrite their "original" tag to MPI_TAG_TERMINATE. !! Second, we iterate this, until all workers are terminated and return without doing any besides. end if call req%state%init_request () call req%state%receive_request () do while (.not. req%state%is_terminated ()) call req%state%await_request () do while (req%state%has_request ()) call req%state%get_request (source, tag, handler) !! Formally differentiate between worker_id and source. worker_id = source if (.not. allocated (req%balancer)) tag = MPI_TAG_TERMINATE select case (tag) case (MPI_TAG_REQUEST) if (req%balancer%is_assignable (worker_id)) then call req%balancer%assign_worker (worker_id, handler) if (.not. req%balancer%has_resource_group (handler)) then call req%state%update_request (source, MPI_TAG_ASSIGN_SINGLE, handler) else call req%state%update_request (source, MPI_TAG_ASSIGN_GROUP, handler) call provide_request_group (handler, source) end if else call req%state%terminate (source) end if case (MPI_TAG_HANDLER_AND_RELEASE) call req%call_handler (handler, source_rank = source) call req%balancer%free_worker (worker_id, handler) case (MPI_TAG_RELEASE) call req%balancer%free_worker (worker_id, handler) case (MPI_TAG_TERMINATE) call req%state%terminate (source) case (MPI_TAG_CLIENT_TERMINATE) !! Allow workers to request their own termination. call req%state%terminate (source) case default call msg_warning () end select end do call req%state%receive_request () end do !! If we are here, there should be no leftover communnication. !! Hence, we must check whether there is no left-over communication call (from server-side). call req%state%free_request () contains subroutine provide_request_group (handler_id, dest_rank) integer, intent(in) :: handler_id integer, intent(in) :: dest_rank integer, dimension(:), allocatable :: rank !! Rank indices and worker indices are identical, as we skip the master worker deliberately, !! we can reuse the worker indices as rank indices. call req%balancer%get_resource_group (handler_id, rank) call req%state%provide_request_group (dest_rank, rank) end subroutine provide_request_group end subroutine request_caller_handle_workload @ %def request_caller_handle_workload @ <>= procedure :: request_workload => request_caller_request_workload <>= module subroutine request_caller_request_workload (req, request) class(request_caller_t), intent(inout) :: req type(request_t), intent(out) :: request end subroutine request_caller_request_workload <>= module subroutine request_caller_request_workload (req, request) class(request_caller_t), intent(inout) :: req type(request_t), intent(out) :: request type(MPI_STATUS) :: status call req%state%client_serve (request%handler_id, status) request%terminate = .false. request%group = .false. request%callback = .false. request%comm = MPI_COMM_NULL select case (status%MPI_TAG) case (MPI_TAG_ASSIGN_SINGLE) !! Default to req's communicator. request%comm = req%external_comm request%group_master = .true. request%callback = .true. case (MPI_TAG_ASSIGN_GROUP) request%group = .true. call retrieve_request_group (request%handler_id) call req%cache%get_comm (request%comm) request%group_master = req%cache%is_master () request%callback = req%cache%is_master () case (MPI_TAG_TERMINATE) request%terminate = status%MPI_TAG == MPI_TAG_TERMINATE end select contains subroutine retrieve_request_group (handler_id) integer, intent(in) :: handler_id integer, dimension(:), allocatable :: rank !! Here, worker and rank indices are interchangeable. call req%state%retrieve_request_group (rank) call req%cache%update (handler_id, rank) end subroutine retrieve_request_group end subroutine request_caller_request_workload @ %def request_caller_request_workload @ <>= procedure :: release_workload => request_caller_release_workload <>= module subroutine request_caller_release_workload (req, request) class(request_caller_t), intent(inout) :: req type(request_t), intent(in) :: request end subroutine request_caller_release_workload <>= module subroutine request_caller_release_workload (req, request) class(request_caller_t), intent(inout) :: req type(request_t), intent(in) :: request call req%state%client_free (request%handler_id, & has_callback = request%group_master) end subroutine request_caller_release_workload @ %def request_caller_release_workload @ <>= procedure :: handle_and_release_workload => & request_caller_handle_and_release_workload <>= module subroutine request_caller_handle_and_release_workload (req, request) class(request_caller_t), intent(inout) :: req type(request_t), intent(in) :: request end subroutine request_caller_handle_and_release_workload <>= module subroutine request_caller_handle_and_release_workload (req, request) class(request_caller_t), intent(inout) :: req type(request_t), intent(in) :: request if (.not. req%handler%has_handler (request%handler_id)) then call msg_bug ("Request: Handler is not registered for this worker.") end if call req%release_workload (request) call req%call_client_handler (request%handler_id) end subroutine request_caller_handle_and_release_workload @ %def request_caller_handle_and_release_workload @ <>= procedure :: request_terminate => request_caller_request_terminate <>= module subroutine request_caller_request_terminate (req) class(request_caller_t), intent(inout) :: req end subroutine request_caller_request_terminate <>= module subroutine request_caller_request_terminate (req) class(request_caller_t), intent(inout) :: req if (req%is_master ()) return call req%state%client_terminate () end subroutine request_caller_request_terminate @ %def request_caller_request_terminate @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Request Caller State} We implement the complete communication for [[request_caller]] into a state (or in WK's nomenclature, instance) object. <<[[request_state.f90]]>>= <> module request_state use, intrinsic :: iso_fortran_env, only: ERROR_UNIT use iterator use mpi_f08 !NODEP! <> <> <> <> interface <> end interface end module request_state @ %def request_state @ <<[[request_state_sub.f90]]>>= <> submodule (request_state) request_state_s use diagnostics - + implicit none contains <> end submodule request_state_s @ %def request_state_s @ <>= integer, parameter, public :: MPI_EMPTY_HANDLER = 0 integer, parameter, public :: MPI_TAG_NULL = 0, & MPI_TAG_REQUEST = 1, & MPI_TAG_RELEASE = 2, & MPI_TAG_HANDLER_AND_RELEASE = 4, & MPI_TAG_TERMINATE = 8, & MPI_TAG_CLIENT_TERMINATE = 16, & MPI_TAG_ASSIGN_SINGLE = 32, & MPI_TAG_ASSIGN_GROUP = 64, & MPI_TAG_COMMUNICATOR_GROUP = 128 integer, parameter :: MPI_STATE_ERR = 1 @ <>= public :: request_state_t <>= type :: request_state_t private type(MPI_COMM) :: comm integer :: n_workers = 0 integer :: n_workers_done = 0 !! From MPI-3.1 book !! i \in {1, N_workes_done}, max size = N_workers type(MPI_Request), dimension(:), allocatable :: request type(MPI_Status), dimension(:), allocatable :: status integer, dimension(:), allocatable :: indices !! i \in {1, N_workers} integer, dimension(:), allocatable :: handler logical, dimension(:), allocatable :: terminated type(iterator_t) :: request_iterator contains <> end type request_state_t @ %def request_state_t @ <>= procedure :: init => request_state_init <>= module subroutine request_state_init (state, comm, n_workers) class(request_state_t), intent(out) :: state type(MPI_COMM), intent(in) :: comm integer, intent(in) :: n_workers end subroutine request_state_init <>= module subroutine request_state_init (state, comm, n_workers) class(request_state_t), intent(out) :: state type(MPI_COMM), intent(in) :: comm integer, intent(in) :: n_workers integer :: rank call MPI_COMM_DUP (comm, state%comm) state%n_workers = n_workers state%n_workers_done = n_workers call state%request_iterator%init (1, n_workers) allocate (state%request(state%n_workers), source = MPI_REQUEST_NULL) allocate (state%status(state%n_workers), source = MPI_STATUS_IGNORE) allocate (state%handler(state%n_workers), source = MPI_EMPTY_HANDLER) allocate (state%indices(state%n_workers), source = 0) allocate (state%terminated(state%n_workers), source = .false.) state%indices = [(rank, rank = 1, n_workers)] end subroutine request_state_init @ %def request_state_init @ <>= procedure :: write => request_state_write <>= module subroutine request_state_write (state, unit) class(request_state_t), intent(in) :: state integer, intent(in), optional :: unit end subroutine request_state_write <>= module subroutine request_state_write (state, unit) class(request_state_t), intent(in) :: state integer, intent(in), optional :: unit integer :: u, i u = ERROR_UNIT; if (present (unit)) u = unit write (u, "(A)") "[REQUEST_STATE]" write (u, "(A,1X,I0)") "N_WORKERS", state%n_workers write (u, "(A,1X,I0)") "N_WORKERS_DONE", state%n_workers_done write (u, "(A)") "RANK | SOURCE | TAG | ERROR | REQUEST_NULL" do i = 1, state%n_workers_done write (u, "(A,4(1X,I0),1X,L1)") "REQUEST", state%indices(i), & state%status(i)%MPI_SOURCE, & state%status(i)%MPI_TAG, & state%status(i)%MPI_ERROR, & (state%request(i) == MPI_REQUEST_NULL) end do write (u, "(A,999(1X,I0))") "HANDLER", state%handler write (u, "(A,999(1X,L1))") "TERMINATED", state%terminated end subroutine request_state_write @ %def request_state_write @ <>= procedure :: reset => request_state_reset <>= module subroutine request_state_reset (state) class(request_state_t), intent(inout) :: state end subroutine request_state_reset <>= module subroutine request_state_reset (state) class(request_state_t), intent(inout) :: state integer :: rank state%n_workers_done = state%n_workers call state%request_iterator%init (1, state%n_workers) state%handler = MPI_EMPTY_HANDLER state%indices = [(rank, rank = 1, state%n_workers)] state%terminated = .false. end subroutine request_state_reset @ %def request_state_reset @ <>= procedure :: is_terminated => request_state_is_terminated <>= module function request_state_is_terminated (state) result (flag) class(request_state_t), intent(in) :: state logical :: flag end function request_state_is_terminated <>= ! pure module function request_state_is_terminated (state) result (flag) module function request_state_is_terminated (state) result (flag) class(request_state_t), intent(in) :: state logical :: flag flag = all (state%terminated) end function request_state_is_terminated @ %def request_state_is_terminated @ Set rank to be terminated (however, do not communicate it). This is an EVIL procedure, as it operates only locally on the master and does not communicate its purpose. However, in order to allow termination requests from client-side we need to manipulate the specific rank states. <>= procedure, private :: set_terminated => request_state_set_terminated <>= module subroutine request_state_set_terminated (state, rank) class(request_state_t), intent(inout) :: state integer, intent(in) :: rank end subroutine request_state_set_terminated <>= module subroutine request_state_set_terminated (state, rank) class(request_state_t), intent(inout) :: state integer, intent(in) :: rank state%terminated(rank) = .true. end subroutine request_state_set_terminated @ %def request_state_set_terminated @ <>= procedure :: terminate => request_state_terminate <>= module subroutine request_state_terminate (state, rank) class(request_state_t), intent(inout) :: state integer, intent(in) :: rank end subroutine request_state_terminate <>= module subroutine request_state_terminate (state, rank) class(request_state_t), intent(inout) :: state integer, intent(in) :: rank integer :: error call MPI_SEND (MPI_EMPTY_HANDLER, 1, MPI_INTEGER, & rank, MPI_TAG_TERMINATE, state%comm, error) if (error /= 0) then write (msg_buffer, "(A,1X,I3)") "Request: Error occured " // & "during terminate, RANK", rank call msg_bug () end if call state%set_terminated (rank) end subroutine request_state_terminate @ %def request_state_terminate @ <>= procedure :: client_terminate => request_state_client_terminate <>= module subroutine request_state_client_terminate (state) class(request_state_t), intent(in) :: state end subroutine request_state_client_terminate <>= module subroutine request_state_client_terminate (state) class(request_state_t), intent(in) :: state integer :: error call MPI_SEND (MPI_EMPTY_HANDLER, 1, MPI_INTEGER, & 0, MPI_TAG_CLIENT_TERMINATE, state%comm, error) if (error /= 0) then write (msg_buffer, "(A,1X,I3)") "Request: Error occured " // & "during client-sided terminate" call msg_bug () end if end subroutine request_state_client_terminate @ %def request_state_client_terminate @ Init persistent requests. Must be called before first -[[receive_request]]. [[Free_request]] must be called after +[[receive_request]]. [[Free_request]] must be called after [[is_terminated]] returns [[true]]. <>= procedure :: init_request => request_state_init_request <>= module subroutine request_state_init_request (state) class(request_state_t), intent(inout) :: state end subroutine request_state_init_request <>= module subroutine request_state_init_request (state) class(request_state_t), intent(inout) :: state integer :: i, rank, error do i = 1, state%n_workers_done rank = state%indices(i) call MPI_RECV_INIT (state%handler(rank), 1, MPI_INTEGER, & rank, MPI_ANY_TAG, state%comm, state%request(rank), error) if (error /= 0) then write (msg_buffer, "(A,2(A,1X,I0))") "Request: Error occured during receive init, & & RANK", rank, "HANDLER", state%handler(rank) call msg_message () call MPI_ABORT (state%comm, MPI_STATE_ERR) end if end do end subroutine request_state_init_request @ %def request_state_init_request @ Receive requests from non-terminated workers. Before receiving new requests, santize arrays of received ranks from terminated ones. <>= procedure :: receive_request => request_state_receive_request <>= module subroutine request_state_receive_request (state) class(request_state_t), intent(inout) :: state end subroutine request_state_receive_request <>= module subroutine request_state_receive_request (state) class(request_state_t), intent(inout) :: state integer :: i, rank integer :: error if (state%is_terminated ()) return call sanitize_from_terminated_ranks () !! Receive new requests from (still active) workers. do i = 1, state%n_workers_done rank = state%indices(i) call MPI_START (state%request(rank), error) if (error /= 0) then write (msg_buffer, "(A,2(A,1X,I6))") "Request: Error occured during receive request, & & RANK", rank, "HANDLER", state%handler(rank) call msg_message () call MPI_ABORT (state%comm, MPI_STATE_ERR) end if end do contains subroutine sanitize_from_terminated_ranks () integer :: n_workers_done integer, dimension(:), allocatable :: indices !! Remove terminated ranks from done workers. indices = pack(state%indices(:state%n_workers_done), & .not. state%terminated(state%indices(:state%n_workers_done))) state%n_workers_done = size (indices) state%indices(:state%n_workers_done) = indices end subroutine sanitize_from_terminated_ranks end subroutine request_state_receive_request @ %def request_state_receive_request @ <>= procedure :: await_request => request_state_await_request <>= module subroutine request_state_await_request (state) class(request_state_t), intent(inout) :: state end subroutine request_state_await_request <>= module subroutine request_state_await_request (state) class(request_state_t), intent(inout) :: state integer :: error if (state%is_terminated ()) return !! We verify that we have active handles associated with request state. call MPI_TESTSOME (state%n_workers, state%request, state%n_workers_done, & state%indices, state%status, error) if (error /= 0) then write (ERROR_UNIT, "(A)") "Error occured during await (testing) request..." call state%write (ERROR_UNIT) call MPI_ABORT (state%comm, MPI_STATE_ERR) else if (state%n_workers_done == MPI_UNDEFINED) then write (ERROR_UNIT, "(A)") "TEST_WAITSOME returned with MPI_UNDEFINED." call state%write (ERROR_UNIT) call MPI_ABORT (state%comm, MPI_STATE_ERR) end if !! Wait a little bit... if (state%n_workers_done == 0) then !! Proof: REQUEST(i), i \in {1, N_workers}, i is equivalent to rank. !! Proof: INDICES(j), STATUS(j), j \in {1, N_workers_done} !! Proof: INDICES(j) -> i, injectiv. call MPI_WAITSOME (state%n_workers, state%request, state%n_workers_done, & state%indices, state%status, error) if (error /= 0) then write (ERROR_UNIT, "(A)") "Error occured during await request..." call state%write (ERROR_UNIT) call MPI_ABORT (state%comm, MPI_STATE_ERR) end if endif call state%request_iterator%init (1, state%n_workers_done) end subroutine request_state_await_request @ %def request_state_await_request @ <>= procedure :: has_request => request_state_has_request <>= pure module function request_state_has_request (state) result (flag) class(request_state_t), intent(in) :: state logical :: flag end function request_state_has_request <>= pure module function request_state_has_request (state) result (flag) class(request_state_t), intent(in) :: state logical :: flag flag = state%request_iterator%is_iterable () end function request_state_has_request @ %def request_state_has_request @ <>= procedure :: get_request => request_state_get_request <>= module subroutine request_state_get_request (state, rank, tag, handler) class(request_state_t), intent(inout) :: state integer, intent(out) :: rank integer, intent(out) :: tag integer, intent(out) :: handler end subroutine request_state_get_request <>= module subroutine request_state_get_request (state, rank, tag, handler) class(request_state_t), intent(inout) :: state integer, intent(out) :: rank integer, intent(out) :: tag integer, intent(out) :: handler integer :: ndx if (.not. state%has_request ()) then call msg_bug ("Request: Cannot access missing request.") end if ndx = state%request_iterator%next () rank = state%indices(ndx) if (rank /= state%status(ndx)%MPI_SOURCE) then write (msg_buffer, "(A,2(1X,I3))") & "Request: RANK and SOURCE mismatch", rank, & state%status(ndx)%MPI_SOURCE call msg_bug () end if tag = state%status(ndx)%MPI_TAG handler = state%handler(rank) end subroutine request_state_get_request @ %def request_state_get_request @ <>= procedure :: update_request => request_state_update_request <>= module subroutine request_state_update_request (state, rank, tag, handler) class(request_state_t), intent(inout) :: state integer, intent(in) :: rank integer, intent(in) :: tag integer, intent(in) :: handler end subroutine request_state_update_request <>= module subroutine request_state_update_request (state, rank, tag, handler) class(request_state_t), intent(inout) :: state integer, intent(in) :: rank integer, intent(in) :: tag integer, intent(in) :: handler integer :: error state%handler(rank) = handler call MPI_SEND (handler, 1, MPI_INTEGER, & rank, tag, state%comm, error) if (error /= 0) then write (msg_buffer, "(A,3(A,1X,I3))") "Request: Error occured during update, & &RANK", rank, "TAG", tag, "HANDLER", handler call msg_bug () end if end subroutine request_state_update_request @ %def request_state_update_request @ <>= procedure :: free_request => request_state_free_request <>= module subroutine request_state_free_request (state) class(request_state_t), intent(inout) :: state end subroutine request_state_free_request <>= module subroutine request_state_free_request (state) class(request_state_t), intent(inout) :: state integer :: rank do rank = 1, state%n_workers if (state%request(rank) == MPI_REQUEST_NULL) cycle call MPI_REQUEST_FREE (state%request(rank)) end do end subroutine request_state_free_request @ %def request_state_free_request @ <>= procedure :: provide_request_group => & request_state_provide_request_group <>= module subroutine request_state_provide_request_group & (state, dest_rank, worker) class(request_state_t), intent(in) :: state integer, intent(in) :: dest_rank integer, dimension(:), intent(in) :: worker end subroutine request_state_provide_request_group <>= module subroutine request_state_provide_request_group & (state, dest_rank, worker) class(request_state_t), intent(in) :: state integer, intent(in) :: dest_rank integer, dimension(:), intent(in) :: worker call MPI_SEND (worker, size (worker), MPI_INTEGER, & dest_rank, MPI_TAG_COMMUNICATOR_GROUP, state%comm) end subroutine request_state_provide_request_group @ %def request_state_provide_request_group @ <>= procedure :: retrieve_request_group => & request_state_retrieve_request_group <>= module subroutine request_state_retrieve_request_group (state, worker) class(request_state_t), intent(inout) :: state integer, dimension(:), allocatable, intent(out) :: worker end subroutine request_state_retrieve_request_group <>= module subroutine request_state_retrieve_request_group (state, worker) class(request_state_t), intent(inout) :: state integer, dimension(:), allocatable, intent(out) :: worker type(MPI_STATUS) :: status integer :: n_workers call MPI_PROBE (0, MPI_TAG_COMMUNICATOR_GROUP, state%comm, status) call MPI_GET_COUNT(status, MPI_INTEGER, n_workers) allocate (worker (n_workers), source = 0) call MPI_RECV (worker, n_workers, MPI_INTEGER, & 0, MPI_TAG_COMMUNICATOR_GROUP, state%comm, status) end subroutine request_state_retrieve_request_group @ %def request_state_retrieve_request_group @ Query for a request (send an request tag, then receive a handler). <>= procedure :: client_serve => request_state_client_serve <>= module subroutine request_state_client_serve (state, handler_id, status) class(request_state_t), intent(in) :: state integer, intent(out) :: handler_id type(MPI_STATUS), intent(out) :: status end subroutine request_state_client_serve <>= module subroutine request_state_client_serve (state, handler_id, status) class(request_state_t), intent(in) :: state integer, intent(out) :: handler_id type(MPI_STATUS), intent(out) :: status call MPI_SEND (MPI_EMPTY_HANDLER, 1, MPI_INTEGER, & 0, MPI_TAG_REQUEST, state%comm) call MPI_RECV (handler_id, 1, MPI_INTEGER, & 0, MPI_ANY_TAG, state%comm, status) end subroutine request_state_client_serve @ %def request_state_client_rate @ Free handler from worker. <>= procedure :: client_free => request_state_client_free <>= module subroutine request_state_client_free (state, handler_id, has_callback) class(request_state_t), intent(in) :: state integer, intent(in) :: handler_id logical, intent(in) :: has_callback end subroutine request_state_client_free <>= module subroutine request_state_client_free (state, handler_id, has_callback) class(request_state_t), intent(in) :: state integer, intent(in) :: handler_id logical, intent(in) :: has_callback integer :: tag tag = merge (MPI_TAG_HANDLER_AND_RELEASE, MPI_TAG_RELEASE, has_callback) call MPI_SEND (handler_id, 1, MPI_INTEGER, & 0, tag, state%comm) end subroutine request_state_client_free @ %def request_state_client_free @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Balancer Base} \begin{description} \item[Balancer Base] Base type for usage for extensions of [[request_base]]. \end{description} <<[[balancer_base.f90]]>>= module balancer_base use array_list <> <> <> <> <> interface <> end interface end module balancer_base @ %def balancer_base @ <<[[balancer_base_sub.f90]]>>= <> submodule (balancer_base) balancer_base_s use io_units use diagnostics implicit none contains <> end submodule balancer_base_s @ %def balancer_base_s @ <>= integer, parameter, public :: STATE_SINGLE = 1, & STATE_ALL = 2 @ <>= type :: worker_t private integer :: resource = 0 integer :: state = 0 integer :: n_resources = 0 logical :: assigned = .false. contains <> end type worker_t @ %def worker_t @ <>= type :: resource_t private integer :: resource_id = 0 logical :: active = .false. integer :: n_assigned_workers = 0 contains <> end type resource_t @ %def resource_t @ <>= public :: resource_state_t <>= type :: resource_state_t integer :: n_workers = 0 integer :: mode = 0 type(array_list_t) :: resource_stack type(array_list_t) :: finished_stack contains <> end type resource_state_t @ %def resource_state_t @ Dynamic load balancer. We organize resources and workers in a transparent way using indices. These indices replace pointer magic. The balancer aggregates a dynamic state, however, we allow the state by the use of a pointer, to access the static fields of the balancer. <>= public :: balancer_base_t <>= type, abstract :: balancer_base_t integer :: n_workers = 0 integer :: n_resources = 0 integer :: n_states = 0 type(worker_t), dimension(:), allocatable :: worker type(resource_t), dimension(:), allocatable :: resource type(resource_state_t), dimension(:), allocatable :: state contains <> end type balancer_base_t @ %def balancer_base_t @ <>= abstract interface subroutine balancer_base_deferred_write (balancer, unit) import :: balancer_base_t class(balancer_base_t), intent(in) :: balancer integer, intent(in), optional :: unit end subroutine balancer_base_deferred_write end interface @ %def balancer_base_deferred_write @ <>= !> Has resource an associated resource group. !! !! \note .true. only on an active resource, else .false. abstract interface pure logical function balancer_base_has_resource_group (balancer, resource_id) & result (flag) import :: balancer_base_t class(balancer_base_t), intent(in) :: balancer integer, intent(in) :: resource_id end function balancer_base_has_resource_group end interface @ %def balancer_base_has_resource_group @ <>= !> Get resource group. !! !! \note Implementation must check against group existence. !! \return group (allocated|NOT allocated for (inactive|non-group) resource) abstract interface pure subroutine balancer_base_get_resource_group (balancer, resource_id, group) import :: balancer_base_t class(balancer_base_t), intent(in) :: balancer integer, intent(in) :: resource_id integer, dimension(:), allocatable, intent(out) :: group end subroutine balancer_base_get_resource_group end interface @ %def balancer_base_get_resource_group @ <>= !> Get resource master (worker). !! !! Return worker as given, however, if extended type is used in a non-local !! or in combination with a commnuicative request type, then check on activation status of associated resource. !! !! \return worker Valid worker index (\in {1, …, N}) only on active resource*, else -1. abstract interface pure integer function balancer_base_get_resource_master (balancer, resource_id) & result (worker) import :: balancer_base_t class(balancer_base_t), intent(in) :: balancer integer, intent(in) :: resource_id end function balancer_base_get_resource_master end interface @ %def balancer_base_get_resource_master @ <>= !> Assign resource to a given worker or retrieve current assigned resource. !! !! If worker has already a resource assigned, return resource. !! If worker has not been assigned a resource, retrieve new resource from state. !! !! \note Each call must check if a worker is assignable, if not, the procedure must return resource_id = -1. abstract interface subroutine balancer_base_assign_worker (balancer, worker_id, resource_id) import :: balancer_base_t class(balancer_base_t), intent(inout) :: balancer integer, intent(in) :: worker_id integer, intent(out) :: resource_id end subroutine balancer_base_assign_worker end interface @ %def balancer_base_assign_worker @ Free assignment of worker. If the worker is not assigned, this procedure is idempotent. If the worker is assigned, alter state correspondingly. In order to correctly free a worker from a resource, we have to explicitly keep track of the association status of a worker and a resource. This feature is mostly relevant for resources with a worker group. The resource may be disassociated from their worker by earlier calls or the former worker may be already assigned to a new resource. In the latter case, we are not allowed to free them (as the new resource is still active). Therefore, each call must check if a worker and resource are still associated and the resource is still active. Only, in this case, disassociating workers and resource is allowed. <>= abstract interface subroutine balancer_base_free_worker (balancer, worker_id, resource_id) import :: balancer_base_t class(balancer_base_t), intent(inout) :: balancer integer, intent(in) :: worker_id integer, intent(in) :: resource_id end subroutine balancer_base_free_worker end interface @ %def balancer_base_free_worker @ <>= - public :: shift_rank_to_worker + public :: shift_rank_to_worker <>= elemental module function shift_rank_to_worker (rank) result (worker) integer, intent(in) :: rank integer :: worker end function shift_rank_to_worker <>= !> Shift rank index to worker index. !! Proof: rank \in {0, …, N - 1}, worker \in {1, …, N} elemental module function shift_rank_to_worker (rank) result (worker) integer, intent(in) :: rank integer :: worker worker = rank + 1 end function shift_rank_to_worker @ %def shift_rank_to_worker @ <>= public :: shift_worker_to_rank <>= elemental module function shift_worker_to_rank (worker) result (rank) integer, intent(in) :: worker integer :: rank end function shift_worker_to_rank <>= !> Shift worker index to rank index. !! Proof: rank \in {0, …, N - 1}, worker \in {1, …, N} elemental module function shift_worker_to_rank (worker) result (rank) integer, intent(in) :: worker integer :: rank rank = worker - 1 end function shift_worker_to_rank @ %def shift_worker_to_rank @ <>= procedure :: write => worker_write <>= module subroutine worker_write (worker, unit) class(worker_t), intent(in) :: worker integer, intent(in), optional :: unit end subroutine worker_write <>= module subroutine worker_write (worker, unit) class(worker_t), intent(in) :: worker integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3(A,1X,I3,1X),A,1X,L1)") "RESOURCE", worker%resource, & "STATE", worker%state, & "N_RESOURCES", worker%n_resources, & "ASSIGNED", worker%assigned end subroutine worker_write @ %def worker_write @ <>= procedure :: is_assigned => worker_is_assigned <>= elemental module function worker_is_assigned (worker) result (flag) class(worker_t), intent(in) :: worker logical :: flag end function worker_is_assigned <>= elemental module function worker_is_assigned (worker) result (flag) class(worker_t), intent(in) :: worker logical :: flag flag = worker%assigned end function worker_is_assigned @ %def worker_is_assigned @ <>= procedure :: get_resource => worker_get_resource <>= elemental module function worker_get_resource (worker) result (resource_id) class(worker_t), intent(in) :: worker integer :: resource_id end function worker_get_resource <>= elemental module function worker_get_resource (worker) result (resource_id) class(worker_t), intent(in) :: worker integer :: resource_id resource_id = worker%resource end function worker_get_resource @ %def worker_get_resource @ <>= procedure :: get_state => worker_get_state <>= elemental module function worker_get_state (worker) result (i_state) class(worker_t), intent(in) :: worker integer :: i_state end function worker_get_state <>= elemental module function worker_get_state (worker) result (i_state) class(worker_t), intent(in) :: worker integer :: i_state i_state = worker%state end function worker_get_state @ %def worker_get_state @ <>= procedure :: add_resource => worker_add_resource <>= elemental module subroutine worker_add_resource (worker, resource_id) class(worker_t), intent(inout) :: worker integer, intent(in) :: resource_id end subroutine worker_add_resource <>= elemental module subroutine worker_add_resource (worker, resource_id) class(worker_t), intent(inout) :: worker integer, intent(in) :: resource_id worker%n_resources = worker%n_resources + 1 worker%assigned = .true. worker%resource = resource_id end subroutine worker_add_resource @ %def worker_add_resource @ <>= procedure :: free => worker_free <>= elemental module subroutine worker_free (worker) class(worker_t), intent(inout) :: worker end subroutine worker_free <>= elemental module subroutine worker_free (worker) class(worker_t), intent(inout) :: worker worker%assigned = .false. worker%resource = 0 end subroutine worker_free @ %def worker_free @ <>= procedure :: write => resource_write <>= module subroutine resource_write (resource, unit) class(resource_t), intent(in) :: resource integer, intent(in), optional :: unit end subroutine resource_write <>= module subroutine resource_write (resource, unit) class(resource_t), intent(in) :: resource integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(A,1X,I3,1X,A,1X,L1,1X,A,1X,I3)") & "RESOURCE_ID", resource%resource_id, & "ACTIVE", resource%active, & "N_ASSIGNED_WORKERS", resource%n_assigned_workers end subroutine resource_write @ %def resource_write @ <>= procedure :: is_active => resource_is_active <>= elemental module function resource_is_active (resource) result (flag) class(resource_t), intent(in) :: resource logical :: flag end function resource_is_active <>= elemental module function resource_is_active (resource) result (flag) class(resource_t), intent(in) :: resource logical :: flag flag = resource%active end function resource_is_active @ %def resource_is_active @ <>= procedure :: set_active => resource_set_active <>= module subroutine resource_set_active (resource, n_workers) class(resource_t), intent(inout) :: resource integer, intent(in) :: n_workers end subroutine resource_set_active <>= module subroutine resource_set_active (resource, n_workers) class(resource_t), intent(inout) :: resource integer, intent(in) :: n_workers resource%active = .true. resource%n_assigned_workers = n_workers end subroutine resource_set_active @ %def resource_set_active @ <>= procedure :: set_inactive => resource_set_inactive <>= module subroutine resource_set_inactive (resource) class(resource_t), intent(inout) :: resource end subroutine resource_set_inactive <>= module subroutine resource_set_inactive (resource) class(resource_t), intent(inout) :: resource resource%active = .false. end subroutine resource_set_inactive @ %def resource_set_inactive @ <>= procedure :: write => resource_state_write <>= module subroutine resource_state_write (state, unit) class(resource_state_t), intent(in) :: state integer, intent(in), optional :: unit end subroutine resource_state_write <>= module subroutine resource_state_write (state, unit) class(resource_state_t), intent(in) :: state integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(A,1X,I0)") "N_STATE_WORKERS", state%n_workers select case (state%mode) case (STATE_SINGLE) write (u, "(A)") "MODE ONE-TO-ONE" case (STATE_ALL) write (u, "(A)") "MODE ALL-TO-ONE" case default write (u, "(A)") "UNSUPPORTED MODE" end select write (u, "(A)") "RESOURCE" call state%resource_stack%write (u) write (u, "(A)") "FINISHED" call state%finished_stack%write (u) end subroutine resource_state_write @ %def resource_state_write @ <>= procedure :: init => resource_state_init <>= module subroutine resource_state_init (state, mode, n_workers) class(resource_state_t), intent(out) :: state integer, intent(in) :: mode integer, intent(in) :: n_workers end subroutine resource_state_init <>= module subroutine resource_state_init (state, mode, n_workers) class(resource_state_t), intent(out) :: state integer, intent(in) :: mode integer, intent(in) :: n_workers state%mode = mode state%n_workers = n_workers call state%resource_stack%init () call state%finished_stack%init () end subroutine resource_state_init @ %def resource_state_init @ <>= procedure :: add_resource => resource_state_add_resource <>= module subroutine resource_state_add_resource (state, i_resource) class(resource_state_t), intent(inout) :: state integer, intent(in) :: i_resource end subroutine resource_state_add_resource <>= module subroutine resource_state_add_resource (state, i_resource) class(resource_state_t), intent(inout) :: state integer, intent(in) :: i_resource call state%resource_stack%add (i_resource) end subroutine resource_state_add_resource @ %def resource_state_add_resource @ <>= procedure :: freeze => resource_state_freeze <>= module subroutine resource_state_freeze (state) class(resource_state_t), intent(inout) :: state - end subroutine resource_state_freeze + end subroutine resource_state_freeze <>= module subroutine resource_state_freeze (state) class(resource_state_t), intent(inout) :: state call state%resource_stack%sort () call state%resource_stack %reverse_order () end subroutine resource_state_freeze @ %def resource_state_freeze @ <>= procedure :: clear => resource_state_clear <>= module subroutine resource_state_clear (state) class(resource_state_t), intent(inout) :: state end subroutine resource_state_clear <>= module subroutine resource_state_clear (state) class(resource_state_t), intent(inout) :: state call state%resource_stack%clear () call state%finished_stack%clear () end subroutine resource_state_clear @ %def resource_state_clear @ <>= procedure :: has_resource => resource_state_has_resource <>= elemental module function resource_state_has_resource (state) result (flag) class(resource_state_t), intent(in) :: state logical :: flag end function resource_state_has_resource <>= elemental module function resource_state_has_resource (state) result (flag) class(resource_state_t), intent(in) :: state logical :: flag flag = .not. state%resource_stack%is_empty () end function resource_state_has_resource @ %def resource_state_has_resoruce @ <>= procedure :: assign_resource => resource_state_assign_resource <>= module function resource_state_assign_resource (state) result (i_resource) class(resource_state_t), intent(inout) :: state integer :: i_resource end function resource_state_assign_resource <>= module function resource_state_assign_resource (state) result (i_resource) class(resource_state_t), intent(inout) :: state integer :: i_resource if (state%resource_stack%is_empty ()) then i_resource = 0 call msg_bug ("Error: No leftover resource on stack.") return end if i_resource = state%resource_stack%remove () !! Pop last element from stack. end function resource_state_assign_resource @ %def resource_state_assign_ressource @ <>= procedure :: free_resource => resource_state_free_resource <>= module subroutine resource_state_free_resource (state, i_resource) class(resource_state_t), intent(inout) :: state integer, intent(in) :: i_resource end subroutine resource_state_free_resource <>= module subroutine resource_state_free_resource (state, i_resource) class(resource_state_t), intent(inout) :: state integer, intent(in) :: i_resource if (state%resource_stack%is_element (i_resource)) then call msg_bug & ("Error: Cannot free resource, still on resource stack.") end if call state%finished_stack%add (i_resource) end subroutine resource_state_free_resource @ %def resource_state_free_resource @ <>= procedure :: base_write => balancer_base_write procedure(balancer_base_deferred_write), deferred :: write <>= module subroutine balancer_base_write (balancer, unit) class(balancer_base_t), intent(in) :: balancer integer, intent(in), optional :: unit end subroutine balancer_base_write <>= module subroutine balancer_base_write (balancer, unit) class(balancer_base_t), intent(in) :: balancer integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(A)") "[REQUEST BALANCER]" write (u, "(3(A,1X,I3,1X))") "N_WORKERS", balancer%n_workers, & "N_RESOURCES", balancer%n_resources, & "N_STATES", balancer%n_states write (u, "(A)") "[WORKER]" do i = 1, balancer%n_workers call balancer%worker(i)%write (u) end do write (u, "(A)") "[RESOURCE]" do i = 1, balancer%n_resources call balancer%resource(i)%write (u) end do write (u, "(A)") "[STATES]" do i = 1, balancer%n_states call balancer%state(i)%write (u) end do end subroutine balancer_base_write @ %def balancer_base_write @ <>= procedure :: base_init => balancer_base_base_init <>= module subroutine balancer_base_base_init (balancer, n_workers, n_resources) class(balancer_base_t), intent(out) :: balancer integer, intent(in) :: n_workers integer, intent(in) :: n_resources end subroutine balancer_base_base_init <>= module subroutine balancer_base_base_init (balancer, n_workers, n_resources) class(balancer_base_t), intent(out) :: balancer integer, intent(in) :: n_workers integer, intent(in) :: n_resources balancer%n_workers = n_workers balancer%n_resources = n_resources allocate (balancer%worker (n_workers)) allocate (balancer%resource (n_resources)) call init_resource () contains subroutine init_resource () integer :: i do i = 1, balancer%n_resources balancer%resource(i)%resource_id = i end do end subroutine init_resource end subroutine balancer_base_base_init @ %def balancer_base_base_init @ Add partition of workers and link with workers.We move the allocated partition object into the balancer. We then assign each partition its respective number of workers in a incrementing linear -fashion. However, we postpone the linking of the resources to the +fashion. However, we postpone the linking of the resources to the partition, which can be either done dynamically with the balancer -state or directly with the appropriate type-bound procedure. +state or directly with the appropriate type-bound procedure. <>= procedure :: add_state => balancer_base_add_state <>= module subroutine balancer_base_add_state (balancer, state) class(balancer_base_t), intent(inout) :: balancer type(resource_state_t), dimension(:), allocatable, intent(inout) :: state end subroutine balancer_base_add_state <>= module subroutine balancer_base_add_state (balancer, state) class(balancer_base_t), intent(inout) :: balancer type(resource_state_t), dimension(:), allocatable, intent(inout) :: state balancer%n_states = size (state) call move_alloc (state, balancer%state) call balancer%link_worker_and_state () end subroutine balancer_base_add_state @ %def balancer_base_add_state @ <>= procedure, private :: link_worker_and_state => & balancer_base_link_worker_and_state <>= module subroutine balancer_base_link_worker_and_state (balancer) class(balancer_base_t), intent(inout) :: balancer end subroutine balancer_base_link_worker_and_state <>= module subroutine balancer_base_link_worker_and_state (balancer) class(balancer_base_t), intent(inout) :: balancer integer :: i, j, i_worker if (.not. allocated (balancer%state)) & call msg_bug ("Error: resource state not allocated.") !! Link worker to a state. i_worker = 1 do i = 1, balancer%n_states do j = 1, balancer%state(i)%n_workers if (i_worker > balancer%n_workers) then call msg_bug ("Balancer: Number of state workers& & exceeding global number of workers") end if associate (worker => balancer%worker(i_worker)) worker%state = i !! Reset worker attributes. worker%resource = 0 worker%n_resources = 0 worker%assigned = .false. end associate i_worker = i_worker + 1 end do end do end subroutine balancer_base_link_worker_and_state @ %def balancer_base_link_worker_and_state @ Is a worker unassigned, or is a worker assigned, but already assigned to an active resource? This is a fence for the [[assign_worker]] TBP. The [[assign_worker]] TBP must call [[is_assignable]] in order to retrieve the worker status. The input is the worker ID, the return flag tells: if the worker is NOT assigned, return [[.true.]] if state has resources. If worker is assigned, return [[.true.]] if associated resource is active. <>= procedure :: is_assignable => balancer_base_is_assignable <>= pure module function balancer_base_is_assignable & (balancer, worker_id) result (flag) class(balancer_base_t), intent(in) :: balancer integer, intent(in) :: worker_id integer :: i_state, resource_id logical :: flag end function balancer_base_is_assignable <>= pure module function balancer_base_is_assignable & (balancer, worker_id) result (flag) class(balancer_base_t), intent(in) :: balancer integer, intent(in) :: worker_id integer :: i_state, resource_id logical :: flag flag = .false. if (balancer%worker(worker_id)%assigned) then resource_id = balancer%worker(worker_id)%resource flag = balancer%resource(resource_id)%is_active () else i_state = balancer%worker(worker_id)%get_state () flag = balancer%state(i_state)%has_resource () end if end function balancer_base_is_assignable @ %def balancer_base_is_assignable @ Is a worker still pending. Test worker assignment, and if there is a (valid) resource and if it is still active. <>= procedure :: is_worker_pending => balancer_base_is_worker_pending <>= pure module function balancer_base_is_worker_pending & (balancer, worker_id) result (flag) class(balancer_base_t), intent(in) :: balancer integer, intent(in) :: worker_id integer :: resource_id logical :: flag end function balancer_base_is_worker_pending <>= pure module function balancer_base_is_worker_pending & (balancer, worker_id) result (flag) class(balancer_base_t), intent(in) :: balancer integer, intent(in) :: worker_id integer :: resource_id logical :: flag flag = balancer%worker(worker_id)%assigned if (flag) then resource_id = balancer%worker(worker_id)%get_resource () flag = balancer%resource(resource_id)%is_active () end if end function balancer_base_is_worker_pending @ %def balancer_base_is_worker_pending @ <>= procedure :: is_pending => balancer_base_is_pending procedure(balancer_base_has_resource_group), deferred :: has_resource_group procedure(balancer_base_get_resource_group), deferred :: get_resource_group procedure(balancer_base_get_resource_master), deferred :: get_resource_master procedure(balancer_base_assign_worker), deferred :: assign_worker procedure(balancer_base_free_worker), deferred :: free_worker <>= module function balancer_base_is_pending (balancer) result (flag) class(balancer_base_t), intent(in) :: balancer logical :: flag end function balancer_base_is_pending <>= module function balancer_base_is_pending (balancer) result (flag) class(balancer_base_t), intent(in) :: balancer logical :: flag flag = all (balancer%state%has_resource ()) end function balancer_base_is_pending @ %def balancer_base_is_pending @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Balancer Simple} This module is the simple balancer. The simple balancer distribute the channel among the N workers using a modulo prescription. However, it does assign all workers to a channel capable of grid with parallelizable structure. The balancer use local, non-communicative approach; each worker allocates an own instance of the balancer and fills it with the respecting resources. We defer possible checks (or sentinels) to the request module, e.g. such as checking whether all channels are computed globally. <<[[balancer_simple.f90]]>>= <> module balancer_simple use balancer_base <> <> <> <> interface <> end interface end module balancer_simple @ %def balancer_simple @ <<[[balancer_simple_sub.f90]]>>= <> submodule (balancer_simple) balancer_simple_s use io_units use diagnostics implicit none contains <> end submodule balancer_simple_s @ %def balancer_simple_s @ <>= integer, parameter :: N_BALANCER_SIMPLE_STATES = 1, & BALANCER_SIMPLE_CHANNEL = 1 -@ +@ <>= public :: balancer_simple_t <>= type, extends (balancer_base_t) :: balancer_simple_t logical, dimension(:), allocatable :: parallel_grid contains <> end type balancer_simple_t @ %def balancer_simple_t @ <>= procedure :: init => balancer_simple_init <>= module subroutine balancer_simple_init (balancer, n_workers, n_resources) class(balancer_simple_t), intent(out) :: balancer integer, intent(in) :: n_workers integer, intent(in) :: n_resources end subroutine balancer_simple_init <>= module subroutine balancer_simple_init (balancer, n_workers, n_resources) class(balancer_simple_t), intent(out) :: balancer integer, intent(in) :: n_workers integer, intent(in) :: n_resources type(resource_state_t), dimension(:), allocatable :: state call balancer%base_init (n_workers, n_resources) allocate (balancer%parallel_grid(n_resources), source = .false.) allocate (state (N_BALANCER_SIMPLE_STATES)) call state(BALANCER_SIMPLE_CHANNEL)%init ( & mode = STATE_SINGLE, & n_workers = balancer%n_workers) call balancer%add_state (state) end subroutine balancer_simple_init @ %def balancer_simple_init @ <>= procedure :: write => balancer_simple_write <>= module subroutine balancer_simple_write (balancer, unit) class(balancer_simple_t), intent(in) :: balancer integer, intent(in), optional :: unit end subroutine balancer_simple_write <>= module subroutine balancer_simple_write (balancer, unit) class(balancer_simple_t), intent(in) :: balancer integer, intent(in), optional :: unit integer :: u, n_size u = given_output_unit (unit) call balancer%base_write (u) n_size = min (25, size (balancer%parallel_grid)) write (u, "(A,25(1X,L1))") "Parallel Grids:", balancer%parallel_grid(:n_size) end subroutine balancer_simple_write @ %def balancer_simple_write @ Update balancer state. Each worker update its own balancer state requiring information about the [[worker_id]]. <>= procedure :: update_state => balancer_simple_update_state <>= module subroutine balancer_simple_update_state & (balancer, worker_id, parallel_grid) class(balancer_simple_t), intent(inout) :: balancer integer, intent(in) :: worker_id logical, dimension(:), intent(in) :: parallel_grid end subroutine balancer_simple_update_state <>= module subroutine balancer_simple_update_state & (balancer, worker_id, parallel_grid) class(balancer_simple_t), intent(inout) :: balancer integer, intent(in) :: worker_id logical, dimension(:), intent(in) :: parallel_grid integer :: ch, worker balancer%parallel_grid = parallel_grid if (.not. allocated (balancer%state)) then call msg_bug ("Error: balancer state not allocated.") end if associate (state => balancer%state(BALANCER_SIMPLE_CHANNEL)) call state%clear () do ch = 1, balancer%n_resources if (parallel_grid(ch)) then call state%add_resource (ch) else worker = balancer%map_channel_to_worker (ch) if (worker == worker_id) then call state%add_resource (ch) end if end if end do call state%freeze () end associate end subroutine balancer_simple_update_state @ %def balancer_simple_update_state @ <>= procedure :: has_resource_group => balancer_simple_has_resource_group <>= pure module function balancer_simple_has_resource_group & (balancer, resource_id) result (flag) class(balancer_simple_t), intent(in) :: balancer integer, intent(in) :: resource_id logical :: flag end function balancer_simple_has_resource_group <>= pure module function balancer_simple_has_resource_group & (balancer, resource_id) result (flag) class(balancer_simple_t), intent(in) :: balancer integer, intent(in) :: resource_id logical :: flag if (.not. balancer%resource(resource_id)%is_active ()) then flag = .false. return end if flag = balancer%parallel_grid (resource_id) end function balancer_simple_has_resource_group @ %def balancer_simple_has_resource_group @ <>= procedure :: get_resource_group => balancer_simple_get_resource_group <>= pure module subroutine balancer_simple_get_resource_group & (balancer, resource_id, group) class(balancer_simple_t), intent(in) :: balancer integer, intent(in) :: resource_id integer, dimension(:), allocatable, intent(out) :: group end subroutine balancer_simple_get_resource_group <>= pure module subroutine balancer_simple_get_resource_group & (balancer, resource_id, group) class(balancer_simple_t), intent(in) :: balancer integer, intent(in) :: resource_id integer, dimension(:), allocatable, intent(out) :: group integer :: i if (.not. balancer%has_resource_group (resource_id)) return group = pack ([(i, i=1,balancer%n_workers)], & mask = balancer%worker%get_resource () == resource_id) end subroutine balancer_simple_get_resource_group @ %def balancer_simple_get_resource_group @ Retrieve resource master holding the results to be communicated. As the simple balancer operates locally on each worker, we do not need to check whether a resource is currently active. All the resources (and their respective order) is fixed at each update of the balancer. <>= procedure :: get_resource_master => balancer_simple_get_resource_master <>= pure module function balancer_simple_get_resource_master & (balancer, resource_id) result (worker_id) class(balancer_simple_t), intent(in) :: balancer integer, intent(in) :: resource_id integer :: worker_id end function balancer_simple_get_resource_master <>= pure module function balancer_simple_get_resource_master & (balancer, resource_id) result (worker_id) class(balancer_simple_t), intent(in) :: balancer integer, intent(in) :: resource_id integer :: worker_id !! \note Do NOT check on resource activation (see interface prescription). if (balancer%parallel_grid(resource_id)) then worker_id = 1 else worker_id = balancer%map_channel_to_worker (resource_id) end if end function balancer_simple_get_resource_master @ %def balancer_simple_get_resource_master @ <>= procedure, private :: map_channel_to_worker => & balancer_simple_map_channel_to_worker <>= pure module function balancer_simple_map_channel_to_worker & (balancer, channel) result (worker) class(balancer_simple_t), intent(in) :: balancer integer, intent(in) :: channel integer :: worker end function balancer_simple_map_channel_to_worker <>= pure module function balancer_simple_map_channel_to_worker & (balancer, channel) result (worker) class(balancer_simple_t), intent(in) :: balancer integer, intent(in) :: channel integer :: worker !! Proof: channel \in {1, N_c}, number of workers N, rank \in {0, …, N - 1} !! Proof: worker \in {1, …, N} !! a = b mod c, then 0 <= a < c worker = mod (channel - 1, balancer%n_workers) + 1 end function balancer_simple_map_channel_to_worker @ %def balancer_simple_map_channel_to_worker @ <>= procedure :: assign_worker => balancer_simple_assign_worker <>= module subroutine balancer_simple_assign_worker (balancer, worker_id, resource_id) class(balancer_simple_t), intent(inout) :: balancer integer, intent(in) :: worker_id integer, intent(out) :: resource_id end subroutine balancer_simple_assign_worker <>= module subroutine balancer_simple_assign_worker (balancer, worker_id, resource_id) class(balancer_simple_t), intent(inout) :: balancer integer, intent(in) :: worker_id integer, intent(out) :: resource_id integer :: i if (.not. balancer%is_assignable (worker_id)) then resource_id = -1 RETURN end if if (balancer%worker(worker_id)%is_assigned ()) then resource_id = balancer%worker(worker_id)%get_resource () RETURN end if associate (state => balancer%state(BALANCER_SIMPLE_CHANNEL)) if (.not. state%has_resource ()) then resource_id = 0 return end if resource_id = state%assign_resource () if (balancer%parallel_grid(resource_id)) then do i = 1, balancer%n_workers if (balancer%is_worker_pending (i)) then write (msg_buffer, "(A,1X,I0,1X,A,1X,I0,1X,A)") & "WORKER", i, "ASSIGNED" call msg_bug () end if call balancer%worker(i)%add_resource (resource_id) end do call balancer%resource(resource_id)%set_active & (n_workers = balancer%n_workers) else call balancer%worker(worker_id)%add_resource (resource_id) call balancer%resource(resource_id)%set_active (n_workers = 1) end if end associate end subroutine balancer_simple_assign_worker @ %def balancer_simple_assign_worker @ <>= procedure :: free_worker => balancer_simple_free_worker <>= module subroutine balancer_simple_free_worker & (balancer, worker_id, resource_id) class(balancer_simple_t), intent(inout) :: balancer integer, intent(in) :: worker_id integer, intent(in) :: resource_id end subroutine balancer_simple_free_worker <>= module subroutine balancer_simple_free_worker & (balancer, worker_id, resource_id) class(balancer_simple_t), intent(inout) :: balancer integer, intent(in) :: worker_id integer, intent(in) :: resource_id integer :: i if (.not. balancer%worker(worker_id)%is_assigned ()) return if (.not. resource_id == & balancer%worker(worker_id)%get_resource ()) then call msg_bug ("Balancer simple: resource and " // & "associated resource do not match.") end if associate (state => balancer%state(BALANCER_SIMPLE_CHANNEL)) call balancer%resource(resource_id)%set_inactive () call state%free_resource (resource_id) if (balancer%parallel_grid(resource_id)) then do i = 1, balancer%n_workers call balancer%worker(i)%free () end do else call balancer%worker(worker_id)%free () end if end associate end subroutine balancer_simple_free_worker @ %def balancer_simple_free_worker @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Balancer Channel} <<[[balancer_channel.f90]]>>= <> module balancer_channel <> use balancer_base <> <> <> <> interface <> end interface end module balancer_channel @ %def balancer_channel @ <<[[balancer_channel_sub.f90]]>>= <> submodule (balancer_channel) balancer_channel_s use io_units use diagnostics implicit none contains <> end submodule balancer_channel_s @ %def balancer_channel_s @ <>= real(default), parameter :: BETA = 1.5_default integer, parameter :: N_BALANCER_CHANNEL_STATE = 2, & CHANNEL_STATE = 1, & GRID_STATE = 2 @ <>= public :: balancer_channel_t <>= type, extends(balancer_base_t) :: balancer_channel_t private integer :: n_parallel_grids = 0 integer :: n_parallel_channels = 0 integer :: n_grid_workers = 0 integer :: n_channel_workers = 0 logical, dimension(:), allocatable :: parallel_grid contains <> end type balancer_channel_t @ %def balancer_channel_t @ <>= procedure :: init => balancer_channel_init <>= module subroutine balancer_channel_init (balancer, n_workers, n_resources) class(balancer_channel_t), intent(out), target :: balancer integer, intent(in) :: n_workers integer, intent(in) :: n_resources end subroutine balancer_channel_init <>= module subroutine balancer_channel_init (balancer, n_workers, n_resources) class(balancer_channel_t), intent(out), target :: balancer integer, intent(in) :: n_workers integer, intent(in) :: n_resources call balancer%base_init (n_workers, n_resources) allocate (balancer%parallel_grid(n_resources), source = .false.) end subroutine balancer_channel_init @ %def balancer_channel_init @ <>= procedure :: write => balancer_channel_write <>= module subroutine balancer_channel_write (balancer, unit) class(balancer_channel_t), intent(in) :: balancer integer, intent(in), optional :: unit end subroutine balancer_channel_write <>= module subroutine balancer_channel_write (balancer, unit) class(balancer_channel_t), intent(in) :: balancer integer, intent(in), optional :: unit integer :: u, n_size u = given_output_unit (unit) write (u, "(A)") "Channel Balancer." write (u, "(A,1X,I3)") "Parallel grids: ", balancer%n_parallel_grids write (u, "(A,1X,I3)") "Parallel channels: ", balancer%n_parallel_channels write (u, "(A,1X,I3)") "Grid workers: ", balancer%n_grid_workers write (u, "(A,1X,I3)") "Channel workers: ", balancer%n_channel_workers n_size = min (25, size (balancer%parallel_grid)) write (u, "(A,25(1X,L1))") "Parallel Grids:", balancer%parallel_grid(:n_size) call balancer%base_write (u) end subroutine balancer_channel_write @ %def balancer_channel_write @ <>= procedure :: update_state => balancer_channel_update_state <>= module subroutine balancer_channel_update_state & (balancer, weight, parallel_grid) class(balancer_channel_t), intent(inout) :: balancer real(default), dimension(:), intent(in) :: weight logical, dimension(:), intent(in) :: parallel_grid end subroutine balancer_channel_update_state <>= module subroutine balancer_channel_update_state & (balancer, weight, parallel_grid) class(balancer_channel_t), intent(inout) :: balancer real(default), dimension(:), intent(in) :: weight logical, dimension(:), intent(in) :: parallel_grid real(default) :: min_parallel_weight balancer%parallel_grid = parallel_grid min_parallel_weight = & balancer%n_resources**(1._default - 1_default / BETA) & / balancer%n_workers**BETA balancer%parallel_grid = & balancer%parallel_grid .and. (weight >= min_parallel_weight) if (balancer%n_resources >= balancer%n_workers) then !! Apply full multi-channel parallelization. balancer%n_parallel_grids = 0 balancer%n_parallel_channels = balancer%n_resources balancer%parallel_grid = .false. balancer%n_grid_workers = 0 balancer%n_channel_workers = balancer%n_workers else if (count (balancer%parallel_grid) == balancer%n_resources) then !! Apply full VEGAS parallelization. balancer%n_parallel_grids = balancer%n_resources balancer%n_parallel_channels = 0 balancer%n_grid_workers = balancer%n_workers balancer%n_channel_workers = 0 else !! Apply mixed mode. balancer%n_parallel_grids = count (balancer%parallel_grid) balancer%n_parallel_channels = balancer%n_resources - & balancer%n_parallel_grids call compute_mixed_mode (weight) end if end if if(allocated (balancer%state)) then deallocate (balancer%state) end if call allocate_state () contains subroutine compute_mixed_mode (weight) real(default), dimension(:), intent(in) :: weight real(default) :: weight_parallel_grids, & ratio_weight, & ratio_n_channels, & ratio !! Apply mixed mode. weight_parallel_grids = sum (weight, balancer%parallel_grid) !! Overall normalization of weight, \f$\alpha_{\text{grids}} + !! \alpha_{\text{channels}} = 1\f$. !! \f$\alpha_{\text{channels}} = 1 - \alpha_{\text{grids}}\f$ ratio_weight = weight_parallel_grids / (1 - weight_parallel_grids) ratio_n_channels = real (balancer%n_parallel_grids, default) & / (balancer%n_resources - balancer%n_parallel_grids) !! The average computation of channel is proportional to its weight. !! Reweight number of channels (per mode) by their summed weights. !! R = w * N / (w * N + w' * N'); primed refer to parallel grid entities. !! = 1 / (1 + w' / w * N' / N) ratio = 1 / (1 + ratio_weight * ratio_n_channels) ratio = min (max (ratio, 0.0_default), 1.0_default) !! Safe-guard ratio computation. !! In the case of small numbers of workers and a very small ratio, !! nint can assign no worker to channel/grid parallelization, !! which is still requested by n_parallel_channels/grids. !! In that case, we have to enforce: n_worker = n_channel_worker + n_grid_worker balancer%n_channel_workers = nint (ratio * balancer%n_workers) balancer%n_grid_workers = nint ((1 - ratio) * balancer%n_workers) !! In the case of small numbers of workers and a very small ratio, !! nint can assign no worker to channel/grid parallelization, !! which is still requested by n_parallel_channels/grids. !! In that case, we have to enforce: n_worker = n_channel_worker + n_grid_worker if (balancer%n_workers >= 2 & .AND. (balancer%n_parallel_channels > 0 .and. balancer%n_channel_workers < 1)) then balancer%n_channel_workers = 1 balancer%n_grid_workers = balancer%n_grid_workers - 1 end if !! The grid resources will only be increased to N = 2 !! if more than 3 workers are present. if (balancer%n_workers >= 3 & .AND. (balancer%n_parallel_grids > 0 .and. balancer%n_grid_workers < 2)) then balancer%n_grid_workers = 2 balancer%n_channel_workers = balancer%n_channel_workers - 2 end if end subroutine compute_mixed_mode subroutine allocate_state () type(resource_state_t), dimension(:), allocatable :: state integer :: ch allocate (state(N_BALANCER_CHANNEL_STATE)) call state(CHANNEL_STATE)%init ( & mode = STATE_SINGLE, & n_workers = balancer%n_channel_workers) call state(GRID_STATE)%init ( & mode = STATE_ALL, & n_workers = balancer%n_grid_workers) do ch = 1, balancer%n_resources if (balancer%parallel_grid(ch)) then call state(GRID_STATE)%add_resource (ch) else call state(CHANNEL_STATE)%add_resource (ch) end if end do call state(CHANNEL_STATE)%freeze () call state(GRID_STATE)%freeze () call balancer%add_state (state) end subroutine allocate_state end subroutine balancer_channel_update_state @ %def balancer_channel_update_state @ <>= procedure :: has_resource_group => balancer_channel_has_resource_group <>= pure module function balancer_channel_has_resource_group & (balancer, resource_id) result (flag) class(balancer_channel_t), intent(in) :: balancer integer, intent(in) :: resource_id logical :: flag end function balancer_channel_has_resource_group <>= pure module function balancer_channel_has_resource_group & (balancer, resource_id) result (flag) class(balancer_channel_t), intent(in) :: balancer integer, intent(in) :: resource_id logical :: flag if (.not. balancer%resource(resource_id)%is_active ()) then flag = .false. return end if flag = balancer%parallel_grid(resource_id) end function balancer_channel_has_resource_group @ %def balancer_channel_has_resource_group @ <>= procedure :: get_resource_group => balancer_channel_get_resource_group <>= pure module subroutine balancer_channel_get_resource_group & (balancer, resource_id, group) class(balancer_channel_t), intent(in) :: balancer integer, intent(in) :: resource_id integer, dimension(:), allocatable, intent(out) :: group end subroutine balancer_channel_get_resource_group <>= pure module subroutine balancer_channel_get_resource_group & (balancer, resource_id, group) class(balancer_channel_t), intent(in) :: balancer integer, intent(in) :: resource_id integer, dimension(:), allocatable, intent(out) :: group integer :: i if (.not. balancer%has_resource_group (resource_id)) return group = pack ([(i, i = 1, balancer%n_workers)], & mask = balancer%worker%get_resource () == resource_id) end subroutine balancer_channel_get_resource_group @ %def balancer_channel_get_resource_group @ <>= procedure :: get_resource_master => balancer_channel_get_resource_master <>= pure module function balancer_channel_get_resource_master & (balancer, resource_id) result (worker_id) class(balancer_channel_t), intent(in) :: balancer integer, intent(in) :: resource_id integer :: worker_id end function balancer_channel_get_resource_master <>= pure module function balancer_channel_get_resource_master & (balancer, resource_id) result (worker_id) class(balancer_channel_t), intent(in) :: balancer integer, intent(in) :: resource_id integer :: worker_id integer :: i if (.not. balancer%resource(resource_id)%is_active ()) then worker_id = -1 return end if !! Linear search. !! First element in worker group is defined as master. associate (worker => balancer%worker) do i = 1, balancer%n_workers if (worker(i)%get_resource () == resource_id) then worker_id = i exit end if end do end associate end function balancer_channel_get_resource_master @ %def balancer_channel_get_resource_master @ <>= procedure :: assign_worker => balancer_channel_assign_worker <>= module subroutine balancer_channel_assign_worker & (balancer, worker_id, resource_id) class(balancer_channel_t), intent(inout) :: balancer integer, intent(in) :: worker_id integer, intent(out) :: resource_id end subroutine balancer_channel_assign_worker <>= module subroutine balancer_channel_assign_worker & (balancer, worker_id, resource_id) class(balancer_channel_t), intent(inout) :: balancer integer, intent(in) :: worker_id integer, intent(out) :: resource_id integer :: i_state if (.not. balancer%is_assignable (worker_id)) then resource_id = -1 return end if if (balancer%worker(worker_id)%is_assigned ()) then resource_id = balancer%worker(worker_id)%get_resource () return end if associate (state => balancer%state) i_state = balancer%worker(worker_id)%get_state () if (.not. state(i_state)%has_resource ()) then resource_id = 0 return end if resource_id = state(i_state)%assign_resource () select case (state(i_state)%mode) case (STATE_SINGLE) call balancer%worker(worker_id)%add_resource (resource_id) call balancer%resource(resource_id)%set_active (n_workers = 1) case (STATE_ALL) call fill_resource_group (i_state, resource_id) end select end associate contains subroutine fill_resource_group (i_state, resource_id) integer, intent(in) :: i_state integer, intent(in) :: resource_id integer :: i, n_workers n_workers = 0 do i = 1, balancer%n_workers if (.not. balancer%worker(i)%get_state () == i_state) cycle if (balancer%is_worker_pending (i)) then write (msg_buffer, "(A,1X,I0,1X,A,1X,I0,1X,A)") & "WORKER", i, "STATE", i_state, "ASSIGNED" call msg_bug () end if call balancer%worker(i)%add_resource (resource_id) n_workers = n_workers + 1 end do if (n_workers /= balancer%state(i_state)%n_workers) then call msg_bug ("Number of assigned workers unequal to " // & "number of state workers.") end if call balancer%resource(resource_id)%set_active (n_workers = n_workers) end subroutine fill_resource_group end subroutine balancer_channel_assign_worker @ %def balancer_channel_assign_worker -@ +@ Free worker from associated resource. Idempotent. Depending on state association, given resource must equal worker's resource (check) for single state. For all state, the *current* resource of the worker may differ (grouping behavior!), only in case, that the older resource is inactive, return as idempotent. Else, free all worker from resource group. <>= procedure :: free_worker => balancer_channel_free_worker <>= module subroutine balancer_channel_free_worker & (balancer, worker_id, resource_id) class(balancer_channel_t), intent(inout) :: balancer integer, intent(in) :: worker_id integer, intent(in) :: resource_id end subroutine balancer_channel_free_worker <>= module subroutine balancer_channel_free_worker & (balancer, worker_id, resource_id) class(balancer_channel_t), intent(inout) :: balancer integer, intent(in) :: worker_id integer, intent(in) :: resource_id integer :: i, i_state if (.not. balancer%worker(worker_id)%is_assigned ()) return associate (state => balancer%state) i_state = balancer%worker(worker_id)%get_state () select case (state(i_state)%mode) case (STATE_SINGLE) if (.not. resource_id == & balancer%worker(worker_id)%get_resource ()) then call msg_bug ("Channel balancer: resource and associated " // & "resource do not match.") end if call balancer%resource(resource_id)%set_inactive () call state(i_state)%free_resource (resource_id) call balancer%worker(worker_id)%free () case (STATE_ALL) if (resource_id /= balancer%worker(worker_id)%get_resource ()) then if (balancer%resource(resource_id)%is_active ()) then msg_buffer = "Channel balancer: resource is still active,& & but worker is assigned to another resource." call msg_bug () else !! Special case: Worker was already freed from (now inactive) !! resource_id (by another call to free_worker), !! and in the mean time assigned to a new resource. !! So, nothing to do. return end if end if call balancer%resource(resource_id)%set_inactive () call state(i_state)%free_resource (resource_id) do i = 1, balancer%n_workers if (.not. balancer%worker(i)%get_state () == i_state) cycle call balancer%worker(i)%free () end do end select end associate end subroutine balancer_channel_free_worker @ %def balancer_channel_free_worker @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Request Callback} \begin{description} \item[request handler] Base type and interface for providing two-sided - communication in a callback fashion. + communication in a callback fashion. \item[request handler manager] Manages handler with a binary tree. \end{description} This module constitutes the request handler. A request handler allows to dispatch an object for communication a priori for a slave and a master. Typically, each slave register its own request handles, whereas the master requests all possible requests handles matching those of the slaves. The requests can then be used later on, e.g. during a computation, a slave may add a request to the master worker and starts sending an object. The master worker looks up the appropriate request handler, which then closes the communication, i.e. by a receive call. Most important: Only a pointer to the buffer object is stored, therefore, the calling function has to ensure, that the communication object (buffer) will not be changed during a request handle (receive or send). Remark: The handler allows for a tag offset which allows to uniqify the the communication. The problem occurs when multiple callback need to handled simultanously and MPI needs to connect the communication calls accordingly. Each message has a tuple of (source, tag, comm) associated, we can uniquify this tuple by a unique tag. [[tag]] $=$ [[tag_offset]] + $\Bigl\{ 1, …,$ [[N_requests]] $\Bigr\}$ where [[tag_offsets]] are multiple of [[N_requests]]. The latter condition should checked by a modulo. What happens if the communication is out of order (is this a problem? check with standard)? <<[[request_callback.f90]]>>= module request_callback use, intrinsic :: iso_fortran_env, only: ERROR_UNIT use binary_tree use mpi_f08 !NODEP! <> <> <> <> interface <> end interface end module request_callback @ %def request_callback @ <<[[request_callback_sub.f90]]>>= <> submodule (request_callback) request_callback_s use diagnostics implicit none contains <> end submodule request_callback_s @ %def request_callback_s @ <>= public :: request_handler_t <>= type, abstract :: request_handler_t integer :: n_requests = 0 integer :: tag_offset = 0 type(MPI_REQUEST), dimension(:), allocatable :: request type(MPI_STATUS), dimension(:), allocatable :: status logical :: activated = .false. logical :: finished = .false. contains procedure :: base_write => request_handler_base_write procedure(request_handler_write), deferred :: write !! \todo{sbrass} implement initialization procedure. procedure(request_handler_handle), deferred :: handle procedure(request_handler_client_handle), deferred :: client_handle procedure :: allocate => request_handler_allocate procedure :: get_status => request_handler_get_status procedure :: testall => request_handler_testall procedure :: waitall => request_handler_waitall procedure :: free => request_handler_free end type request_handler_t @ %def request_handler_t @ <>= public :: request_handler_manager_t <>= type :: request_handler_manager_t private type(MPI_COMM) :: comm type(binary_tree_t) :: tree contains <> end type request_handler_manager_t @ %def request_handler_manager_t @ <>= abstract interface subroutine request_handler_write (handler, unit) import :: request_handler_t class(request_handler_t), intent(in) :: handler integer, intent(in), optional :: unit end subroutine request_handler_write end interface @ %def request_handler_write @ <>= abstract interface !> Handle a request from server side. !! !! The message tag can be used in order to uniquify the respective messages between master and slave. !! E.g. by explicitly setting it, or by using it in a computation i * N_R + j, i \in {1, …, N} and j \in {1, …, N_R}. !! !! Must set *activated* to .true. when called. !! \param[in] source Integer rank of the source in comm. !! \param[in] tag Specify the message tag. !! \param[in] comm MPI communicator. subroutine request_handler_handle (handler, source_rank, comm) import :: request_handler_t, MPI_COMM class(request_handler_t), intent(inout) :: handler integer, intent(in) :: source_rank type(MPI_COMM), intent(in) :: comm end subroutine request_handler_handle end interface @ %def request_handler_handle @ <>= abstract interface !> Handle a request from client side. !! !! Must set *activated* to .true. when called. !! \param[in] rank Integer of the receiver in comm. !! \param[in] tag Specify the message tag. !! \param[in] comm MPI communicator. subroutine request_handler_client_handle (handler, dest_rank, comm) import :: request_handler_t, MPI_COMM class(request_handler_t), intent(inout) :: handler integer, intent(in) :: dest_rank type(MPI_COMM), intent(in) :: comm end subroutine request_handler_client_handle end interface @ %def request_handler_client_handle @ Request handler. Write routine. <>= module subroutine request_handler_base_write (handler, unit) class(request_handler_t), intent(in) :: handler integer, intent(in), optional :: unit end subroutine request_handler_base_write <>= module subroutine request_handler_base_write (handler, unit) class(request_handler_t), intent(in) :: handler integer, intent(in), optional :: unit integer :: u, i u = ERROR_UNIT; if (present (unit)) u = unit write (u, "(A,1X,I0)") "N_REQUESTS", handler%n_requests write (u, "(A,1X,I0)") "TAG_OFFSET", handler%tag_offset write (u, "(A,1X,L1)") "FINISHED", handler%finished write (u, "(A,1X,L1)") "ACTIVATED", handler%activated write (u, "(A)") "I | SOURCE | TAG | ERROR | REQUEST_NULL" do i = 1, handler%n_requests write (u, "(A,4(1X,I0),1X,L1)") "REQUEST", i, & handler%status(i)%MPI_SOURCE, & handler%status(i)%MPI_TAG, & handler%status(i)%MPI_ERROR, & (handler%request(i) == MPI_REQUEST_NULL) end do end subroutine request_handler_base_write @ %def request_handler_base_write @ Allocate MPI request and status object. Must be called during or after object-initialization. <>= module subroutine request_handler_allocate (handler, n_requests, tag_offset) class(request_handler_t), intent(inout) :: handler integer, intent(in) :: n_requests integer, intent(in) :: tag_offset end subroutine request_handler_allocate <>= !! \param[inout] handler Handler must be intent inout, as the calling function may already manipulated the extended object. !! \param[in] n_requests Number of MPI requests the objects needs to be able to handle. !! \param[in] tag_offset First tag to be used, all other must follow in an increasing manner until tag_offset + (N_r + 1). !! Proof: tag \in {tag_offset, tag_offset + n_requests}. module subroutine request_handler_allocate (handler, n_requests, tag_offset) class(request_handler_t), intent(inout) :: handler integer, intent(in) :: n_requests integer, intent(in) :: tag_offset allocate (handler%request(n_requests), source = MPI_REQUEST_NULL) allocate (handler%status(n_requests)) handler%n_requests = n_requests if (mod (tag_offset, n_requests) /= 0) & call msg_bug ("Error during handler allocate, tag_offset " // & "is not a multiple of n_requests.") !! What is the max.-allowed MPI_TAG? handler%tag_offset = tag_offset handler%activated = .false. handler%finished = .false. end subroutine request_handler_allocate @ %def request_handler_allocate @ Get status from request objects in a non-destructive way. <>= module subroutine request_handler_get_status (handler) class(request_handler_t), intent(inout) :: handler end subroutine request_handler_get_status <>= module subroutine request_handler_get_status (handler) class(request_handler_t), intent(inout) :: handler integer :: i logical :: flag if (.not. handler%activated) return handler%finished = .true. do i = 1, handler%n_requests call MPI_REQUEST_GET_STATUS (handler%request(i), flag, & handler%status(i)) handler%finished = handler%finished .and. flag end do end subroutine request_handler_get_status @ %def request_handler_get_status @ Call [[MPI_WATIALL]] and raise finished flag. <>= module subroutine request_handler_waitall (handler) class(request_handler_t), intent(inout) :: handler end subroutine request_handler_waitall <>= module subroutine request_handler_waitall (handler) class(request_handler_t), intent(inout) :: handler integer :: error if (.not. handler%activated .or. handler%finished) return call MPI_WAITALL (handler%n_requests, handler%request, & handler%status, error) if (error /= 0) then call msg_bug ("Request: Error occured during waitall on handler.") end if handler%finished = .true. end subroutine request_handler_waitall @ %def request_handler_waitall @ <>= module function request_handler_testall (handler) result (flag) class(request_handler_t), intent(inout) :: handler logical :: flag end function request_handler_testall <>= module function request_handler_testall (handler) result (flag) class(request_handler_t), intent(inout) :: handler logical :: flag integer :: error if (.not. handler%activated .or. .not. handler%finished) then call MPI_TESTALL (handler%n_requests, handler%request, & handler%finished, handler%status, error) ! call print_status () if (error /= 0) then call msg_bug ("Request: Error occured during testall on handler.") end if end if flag = handler%finished contains subroutine print_status () integer :: i do i = 1, handler%n_requests associate (status => handler%status(i)) write (ERROR_UNIT, *) status%MPI_SOURCE, status%MPI_TAG, & status%MPI_ERROR end associate end do end subroutine print_status end function request_handler_testall @ %def request_handler_testall @ <>= module subroutine request_handler_free (handler) class(request_handler_t), intent(inout) :: handler end subroutine request_handler_free <>= module subroutine request_handler_free (handler) class(request_handler_t), intent(inout) :: handler integer :: i, error do i = 1, handler%n_requests if (handler%request(i) == MPI_REQUEST_NULL) cycle call MPI_REQUEST_FREE (handler%request(i), error) if (error /= 0) then call msg_bug ("Request: Error occured during free " // & "request on handler.") end if end do end subroutine request_handler_free @ %def request_handler_free @ Request handler manager. <>= procedure :: init => request_handler_manager_init <>= module subroutine request_handler_manager_init (rhm, comm) class(request_handler_manager_t), intent(out) :: rhm type(MPI_COMM), intent(in) :: comm end subroutine request_handler_manager_init <>= module subroutine request_handler_manager_init (rhm, comm) class(request_handler_manager_t), intent(out) :: rhm type(MPI_COMM), intent(in) :: comm call MPI_COMM_DUP (comm, rhm%comm) end subroutine request_handler_manager_init -@ %def request_handler_manager_init +@ %def request_handler_manager_init @ <>= procedure :: write => request_handler_manager_write <>= module subroutine request_handler_manager_write (rhm, unit) class(request_handler_manager_t), intent(in) :: rhm integer, intent(in), optional :: unit end subroutine request_handler_manager_write <>= module subroutine request_handler_manager_write (rhm, unit) class(request_handler_manager_t), intent(in) :: rhm integer, intent(in), optional :: unit integer :: u u = ERROR_UNIT; if (present (unit)) u = unit write (u, "(A)") "[REQUEST_CALLBACK_MANAGER]" call rhm%tree%write (u) end subroutine request_handler_manager_write @ %def request_handler_manager_write @ <>= procedure :: add => request_handler_manager_add <>= module subroutine request_handler_manager_add (rhm, handler_id, handler) class(request_handler_manager_t), intent(inout) :: rhm integer, intent(in) :: handler_id class(request_handler_t), pointer, intent(in) :: handler end subroutine request_handler_manager_add <>= module subroutine request_handler_manager_add (rhm, handler_id, handler) class(request_handler_manager_t), intent(inout) :: rhm integer, intent(in) :: handler_id class(request_handler_t), pointer, intent(in) :: handler class(*), pointer :: obj obj => handler call rhm%tree%insert (handler_id, obj) end subroutine request_handler_manager_add @ %def request_handler_manager_add @ <>= procedure :: clear => request_handler_manager_clear <>= module subroutine request_handler_manager_clear (rhm) class(request_handler_manager_t), intent(inout) :: rhm end subroutine request_handler_manager_clear <>= module subroutine request_handler_manager_clear (rhm) class(request_handler_manager_t), intent(inout) :: rhm call rhm%tree%clear () end subroutine request_handler_manager_clear @ %def request_handler_manager_clear @ Get status (in a non-destructive way) for all associated handler. <>= procedure, private :: fill_status => request_handler_manager_fill_status <>= module subroutine request_handler_manager_fill_status (rhm) class(request_handler_manager_t), intent(inout) :: rhm end subroutine request_handler_manager_fill_status <>= module subroutine request_handler_manager_fill_status (rhm) class(request_handler_manager_t), intent(inout) :: rhm type(binary_tree_iterator_t) :: iterator integer :: handler_id class(request_handler_t), pointer :: handler call iterator%init (rhm%tree) do while (iterator%is_iterable ()) call iterator%next (handler_id) call rhm%handler_at (handler_id, handler) call handler%get_status () end do end subroutine request_handler_manager_fill_status @ %def request_handler_manager_fill_status @ <>= procedure :: test => request_handler_manager_test <>= module function request_handler_manager_test & (rhm, handler_id) result (flag) class(request_handler_manager_t), intent(inout) :: rhm integer, intent(in) :: handler_id logical :: flag end function request_handler_manager_test <>= module function request_handler_manager_test & (rhm, handler_id) result (flag) class(request_handler_manager_t), intent(inout) :: rhm integer, intent(in) :: handler_id logical :: flag class(request_handler_t), pointer :: handler call rhm%handler_at (handler_id, handler) flag = handler%testall () end function request_handler_manager_test @ %def request_handler_manager_test @ <>= procedure :: wait => request_handler_manager_wait <>= module subroutine request_handler_manager_wait (rhm, handler_id) class(request_handler_manager_t), intent(inout) :: rhm integer, intent(in) :: handler_id end subroutine request_handler_manager_wait <>= module subroutine request_handler_manager_wait (rhm, handler_id) class(request_handler_manager_t), intent(inout) :: rhm integer, intent(in) :: handler_id class(request_handler_t), pointer :: handler call rhm%handler_at (handler_id, handler) call handler%waitall () end subroutine request_handler_manager_wait @ %def request_handler_manager_wait @ <>= procedure :: waitall => request_handler_manager_waitall <>= module subroutine request_handler_manager_waitall (rhm) class(request_handler_manager_t), intent(inout) :: rhm end subroutine request_handler_manager_waitall <>= module subroutine request_handler_manager_waitall (rhm) class(request_handler_manager_t), intent(inout) :: rhm type(binary_tree_iterator_t) :: iterator integer :: handler_id call iterator%init (rhm%tree) do while (iterator%is_iterable ()) call iterator%next (handler_id) !! Test handler (destructive test on request handler). if (.not. rhm%test (handler_id)) & call rhm%wait (handler_id) end do end subroutine request_handler_manager_waitall @ %def request_handler_manager_waitall @ <>= procedure, private :: handler_at => request_handler_manager_handler_at <>= module subroutine request_handler_manager_handler_at & (rhm, handler_id, handler) class(request_handler_manager_t), intent(in) :: rhm integer, intent(in) :: handler_id class(request_handler_t), pointer, intent(out) :: handler end subroutine request_handler_manager_handler_at <>= module subroutine request_handler_manager_handler_at & (rhm, handler_id, handler) class(request_handler_manager_t), intent(in) :: rhm integer, intent(in) :: handler_id class(request_handler_t), pointer, intent(out) :: handler class(*), pointer :: obj call rhm%tree%search (handler_id, obj) select type (obj) class is (request_handler_t) handler => obj class default call msg_bug ("Object is not derived from request_handler_t.") end select end subroutine request_handler_manager_handler_at @ %def request_handler_manager_handler_at @ <>= procedure :: has_handler => request_handler_manager_has_handler <>= module function request_handler_manager_has_handler & (rhm, handler_id) result (flag) class(request_handler_manager_t), intent(inout) :: rhm integer, intent(in) :: handler_id logical :: flag end function request_handler_manager_has_handler <>= module function request_handler_manager_has_handler & (rhm, handler_id) result (flag) class(request_handler_manager_t), intent(inout) :: rhm integer, intent(in) :: handler_id logical :: flag flag = rhm%tree%has_key (handler_id) end function request_handler_manager_has_handler @ %def request_handler_manager_has_handler @ Call server-sided procedure of callback with [[handler_id]]. Ingoing variables are [[handler_id]] and [[source]]. <>= procedure :: callback => request_handler_manager_callback <>= module subroutine request_handler_manager_callback & (rhm, handler_id, source_rank) class(request_handler_manager_t), intent(inout) :: rhm integer, intent(in) :: handler_id integer, intent(in) :: source_rank end subroutine request_handler_manager_callback <>= module subroutine request_handler_manager_callback & (rhm, handler_id, source_rank) class(request_handler_manager_t), intent(inout) :: rhm integer, intent(in) :: handler_id integer, intent(in) :: source_rank class(request_handler_t), pointer :: handler if (.not. rhm%tree%has_key (handler_id)) return call rhm%handler_at (handler_id, handler) call handler%handle (source_rank = source_rank, comm = rhm%comm) end subroutine request_handler_manager_callback @ %def request_handler_manager_callback @ Call client-sided procedure of callback with [[handler_id]], which is the input, as well as the destination rank. <>= procedure :: client_callback => request_handler_manager_client_callback <>= module subroutine request_handler_manager_client_callback & (rhm, handler_id, dest_rank) class(request_handler_manager_t), intent(inout) :: rhm integer, intent(in) :: handler_id integer, intent(in) :: dest_rank end subroutine request_handler_manager_client_callback <>= module subroutine request_handler_manager_client_callback & (rhm, handler_id, dest_rank) class(request_handler_manager_t), intent(inout) :: rhm integer, intent(in) :: handler_id integer, intent(in) :: dest_rank class(request_handler_t), pointer :: handler if (.not. rhm%tree%has_key (handler_id)) return call rhm%handler_at (handler_id, handler) call handler%client_handle (dest_rank = dest_rank, comm = rhm%comm) end subroutine request_handler_manager_client_callback @ %def request_handlder_manager_client_callback @ Index: trunk/src/mci/mci.nw =================================================================== --- trunk/src/mci/mci.nw (revision 8827) +++ trunk/src/mci/mci.nw (revision 8828) @@ -1,15857 +1,15857 @@ %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; noweb-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: integration and event generation %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Multi-Channel Integration} \includemodulegraph{mci} The abstract representation of multi-channel Monte Carlo algorithms for integration and event generation. \begin{description} \item[Module [[mci_base]]:] The abstract types and their methods. It provides a test integrator that is referenced in later unit tests. \item[iterations] Container for defining integration call and pass settings. \item[integration\_results] This module handles results from integrating processes. It records passes and iterations, calculates statistical averages, and provides the user output of integration results. \end{description} These are the implementations: \begin{description} \item[Module [[mci_midpoint]]:] A simple integrator that uses the midpoint rule to sample the integrand uniformly over the unit hypercube. There is only one integration channel, so this can be matched only to single-channel phase space. \item[Module [[mci_vamp]]:] Interface for the VAMP package. \end{description} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \clearpage \section{Generic Integrator} This module provides a multi-channel integrator (MCI) base type, a corresponding configuration type, and methods for integration and event generation. <<[[mci_base.f90]]>>= <> module mci_base use kinds use cputime use phs_base use rng_base <> <> <> <> interface <> end interface end module mci_base @ %def mci_base @ <<[[mci_base_sub.f90]]>>= <> submodule (mci_base) mci_base_s use io_units use format_utils, only: pac_fmt use format_defs, only: FMT_14, FMT_17 use diagnostics implicit none contains <> end submodule mci_base_s @ %def mci_base_s @ \subsection{MCI: integrator} The MCI object contains the methods for integration and event generation. For the actual work and data storage, it spawns an MCI instance object. The base object contains the number of integration dimensions and the number of channels as configuration data. Further configuration data are stored in the concrete extensions. The MCI sum contains all relevant information about the integrand. It can be used for comparing the current configuration against a previous one. If they match, we can skip an actual integration. (Implemented only for the VAMP version.) There is a random-number generator (its state with associated methods) available as [[rng]]. It may or may not be used for integration. It will be used for event generation. <>= public :: mci_t <>= type, abstract :: mci_t integer :: n_dim = 0 integer :: n_channel = 0 integer :: n_chain = 0 integer, dimension(:), allocatable :: chain real(default), dimension(:), allocatable :: chain_weights character(32) :: md5sum = "" logical :: integral_known = .false. logical :: error_known = .false. logical :: efficiency_known = .false. real(default) :: integral = 0 real(default) :: error = 0 real(default) :: efficiency = 0 logical :: use_timer = .false. type(timer_t) :: timer class(rng_t), allocatable :: rng contains <> end type mci_t @ %def mci_t @ Finalizer: the random-number generator may need one. <>= procedure :: base_final => mci_final procedure (mci_final), deferred :: final <>= module subroutine mci_final (object) class(mci_t), intent(inout) :: object end subroutine mci_final <>= module subroutine mci_final (object) class(mci_t), intent(inout) :: object if (allocated (object%rng)) call object%rng%final () end subroutine mci_final @ %def mci_final @ Output: basic and extended output. <>= procedure :: base_write => mci_write procedure (mci_write), deferred :: write <>= module subroutine mci_write (object, unit, pacify, md5sum_version) class(mci_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version end subroutine mci_write <>= module subroutine mci_write (object, unit, pacify, md5sum_version) class(mci_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version logical :: md5sum_ver integer :: u, i, j character(len=7) :: fmt call pac_fmt (fmt, FMT_17, FMT_14, pacify) u = given_output_unit (unit) md5sum_ver = .false. if (present (md5sum_version)) md5sum_ver = md5sum_version if (object%use_timer .and. .not. md5sum_ver) then write (u, "(2x)", advance="no") call object%timer%write (u) end if if (object%integral_known) then write (u, "(3x,A," // fmt // ")") & "Integral = ", object%integral end if if (object%error_known) then write (u, "(3x,A," // fmt // ")") & "Error = ", object%error end if if (object%efficiency_known) then write (u, "(3x,A," // fmt // ")") & "Efficiency = ", object%efficiency end if write (u, "(3x,A,I0)") "Number of channels = ", object%n_channel write (u, "(3x,A,I0)") "Number of dimensions = ", object%n_dim if (object%n_chain > 0) then write (u, "(3x,A,I0)") "Number of chains = ", object%n_chain write (u, "(3x,A)") "Chains:" do i = 1, object%n_chain write (u, "(5x,I0,':')", advance = "no") i do j = 1, object%n_channel if (object%chain(j) == i) & write (u, "(1x,I0)", advance = "no") j end do write (u, "(A)") end do end if end subroutine mci_write @ %def mci_write @ Print an informative message when starting integration. <>= procedure (mci_startup_message), deferred :: startup_message procedure :: base_startup_message => mci_startup_message <>= module subroutine mci_startup_message (mci, unit, n_calls) class(mci_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls end subroutine mci_startup_message <>= module subroutine mci_startup_message (mci, unit, n_calls) class(mci_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls if (mci%n_chain > 0) then write (msg_buffer, "(A,3(1x,I0,1x,A))") & "Integrator:", mci%n_chain, "chains,", & mci%n_channel, "channels,", & mci%n_dim, "dimensions" else write (msg_buffer, "(A,3(1x,I0,1x,A))") & "Integrator:", & mci%n_channel, "channels,", & mci%n_dim, "dimensions" end if call msg_message (unit = unit) end subroutine mci_startup_message @ %def mci_startup_message @ Dump type-specific info to a logfile. <>= procedure(mci_write_log_entry), deferred :: write_log_entry <>= abstract interface subroutine mci_write_log_entry (mci, u) import class(mci_t), intent(in) :: mci integer, intent(in) :: u end subroutine mci_write_log_entry end interface @ %def mci_write_log_entry In order to avoid dependencies on definite MCI implementations, we introduce a MD5 sum calculator. <>= procedure(mci_compute_md5sum), deferred :: compute_md5sum <>= abstract interface subroutine mci_compute_md5sum (mci, pacify) import class(mci_t), intent(inout) :: mci logical, intent(in), optional :: pacify end subroutine mci_compute_md5sum end interface @ %def mci_compute_md5sum @ Record the index of the MCI object within a process. For multi-component processes with more than one integrator, the integrator should know about its own index, so file names can be unique, etc. The default implementation does nothing, however. <>= procedure :: record_index => mci_record_index <>= module subroutine mci_record_index (mci, i_mci) class(mci_t), intent(inout) :: mci integer, intent(in) :: i_mci end subroutine mci_record_index <>= module subroutine mci_record_index (mci, i_mci) class(mci_t), intent(inout) :: mci integer, intent(in) :: i_mci end subroutine mci_record_index @ %def mci_record_index @ There is no Initializer for the abstract type, but a generic setter for the number of channels and dimensions. We make two aliases available, to be able to override it. <>= procedure :: set_dimensions => mci_set_dimensions procedure :: base_set_dimensions => mci_set_dimensions <>= module subroutine mci_set_dimensions (mci, n_dim, n_channel) class(mci_t), intent(inout) :: mci integer, intent(in) :: n_dim integer, intent(in) :: n_channel end subroutine mci_set_dimensions <>= module subroutine mci_set_dimensions (mci, n_dim, n_channel) class(mci_t), intent(inout) :: mci integer, intent(in) :: n_dim integer, intent(in) :: n_channel mci%n_dim = n_dim mci%n_channel = n_channel end subroutine mci_set_dimensions @ %def mci_set_dimensions @ Declare particular dimensions as flat. This information can be used to simplify integration. When generating events, the flat dimensions should be sampled with uniform and uncorrelated distribution. It depends on the integrator what to do with that information. <>= procedure (mci_declare_flat_dimensions), deferred :: declare_flat_dimensions <>= abstract interface subroutine mci_declare_flat_dimensions (mci, dim_flat) import class(mci_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat end subroutine mci_declare_flat_dimensions end interface @ %def mci_declare_flat_dimensions @ Declare particular channels as equivalent, possibly allowing for permutations or reflections of dimensions. We use the information stored in the [[phs_channel_t]] object array that the phase-space module provides. (We do not test this here, deferring the unit test to the [[mci_vamp]] implementation where we actually use this feature.) <>= procedure (mci_declare_equivalences), deferred :: declare_equivalences <>= abstract interface subroutine mci_declare_equivalences (mci, channel, dim_offset) import class(mci_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset end subroutine mci_declare_equivalences end interface @ %def mci_declare_equivalences @ Declare particular channels as chained together. The implementation may use this array for keeping their weights equal to each other, etc. The chain array is an array sized by the number of channels. For each channel, there is an integer entry that indicates the correponding chains. The total number of chains is the maximum value of this entry. <>= procedure :: declare_chains => mci_declare_chains <>= module subroutine mci_declare_chains (mci, chain) class(mci_t), intent(inout) :: mci integer, dimension(:), intent(in) :: chain end subroutine mci_declare_chains <>= module subroutine mci_declare_chains (mci, chain) class(mci_t), intent(inout) :: mci integer, dimension(:), intent(in) :: chain allocate (mci%chain (size (chain))) mci%n_chain = maxval (chain) allocate (mci%chain_weights (mci%n_chain), source = 0._default) mci%chain = chain end subroutine mci_declare_chains @ %def mci_declare_chains @ Collect channel weights according to chains and store them in the [[chain_weights]] for output. We sum up the weights for all channels that share the same [[chain]] index and store the results in the [[chain_weights]] array. <>= procedure :: collect_chain_weights => mci_collect_chain_weights <>= module subroutine mci_collect_chain_weights (mci, weight) class(mci_t), intent(inout) :: mci real(default), dimension(:), intent(in) :: weight end subroutine mci_collect_chain_weights <>= module subroutine mci_collect_chain_weights (mci, weight) class(mci_t), intent(inout) :: mci real(default), dimension(:), intent(in) :: weight integer :: i, c if (allocated (mci%chain)) then mci%chain_weights = 0 do i = 1, size (mci%chain) c = mci%chain(i) mci%chain_weights(c) = mci%chain_weights(c) + weight(i) end do end if end subroutine mci_collect_chain_weights @ %def mci_collect_chain_weights @ Check if there are chains. <>= procedure :: has_chains => mci_has_chains <>= module function mci_has_chains (mci) result (flag) class(mci_t), intent(in) :: mci logical :: flag end function mci_has_chains <>= module function mci_has_chains (mci) result (flag) class(mci_t), intent(in) :: mci logical :: flag flag = allocated (mci%chain) end function mci_has_chains @ %def mci_has_chains @ Output of the chain weights, kept separate from the main [[write]] method. [The formatting will work as long as the number of chains is less than $10^{10}$\ldots] <>= procedure :: write_chain_weights => mci_write_chain_weights <>= module subroutine mci_write_chain_weights (mci, unit) class(mci_t), intent(in) :: mci integer, intent(in), optional :: unit end subroutine mci_write_chain_weights <>= module subroutine mci_write_chain_weights (mci, unit) class(mci_t), intent(in) :: mci integer, intent(in), optional :: unit integer :: u, i, n, n_digits character(4) :: ifmt u = given_output_unit (unit) if (allocated (mci%chain_weights)) then write (u, "(1x,A)") "Weights of channel chains (groves):" n_digits = 0 n = size (mci%chain_weights) do while (n > 0) n = n / 10 n_digits = n_digits + 1 end do write (ifmt, "(A1,I1)") "I", n_digits do i = 1, size (mci%chain_weights) write (u, "(3x," // ifmt // ",F13.10)") i, mci%chain_weights(i) end do end if end subroutine mci_write_chain_weights @ %def mci_write_chain_weights @ Set the MD5 sum, independent of initialization. <>= procedure :: set_md5sum => mci_set_md5sum <>= module subroutine mci_set_md5sum (mci, md5sum) class(mci_t), intent(inout) :: mci character(32), intent(in) :: md5sum end subroutine mci_set_md5sum <>= module subroutine mci_set_md5sum (mci, md5sum) class(mci_t), intent(inout) :: mci character(32), intent(in) :: md5sum mci%md5sum = md5sum end subroutine mci_set_md5sum @ %def mci_set_md5sum @ Initialize a new integration pass. This is not necessarily meaningful, so we provide an empty base method. The [[mci_vamp]] implementation overrides this. <>= procedure :: add_pass => mci_add_pass <>= module subroutine mci_add_pass (mci, adapt_grids, adapt_weights, final_pass) class(mci_t), intent(inout) :: mci logical, intent(in), optional :: adapt_grids logical, intent(in), optional :: adapt_weights logical, intent(in), optional :: final_pass end subroutine mci_add_pass <>= module subroutine mci_add_pass (mci, adapt_grids, adapt_weights, final_pass) class(mci_t), intent(inout) :: mci logical, intent(in), optional :: adapt_grids logical, intent(in), optional :: adapt_weights logical, intent(in), optional :: final_pass end subroutine mci_add_pass @ %def mci_add_pass @ Allocate an instance with matching type. This must be deferred. <>= procedure (mci_allocate_instance), deferred :: allocate_instance <>= abstract interface subroutine mci_allocate_instance (mci, mci_instance) import class(mci_t), intent(in) :: mci class(mci_instance_t), intent(out), pointer :: mci_instance end subroutine mci_allocate_instance end interface @ %def mci_allocate_instance @ Import a random-number generator. We transfer the allocation of an existing generator state into the object. The generator state may already be initialized, or we can reset it by its [[init]] method. <>= procedure :: import_rng => mci_import_rng <>= module subroutine mci_import_rng (mci, rng) class(mci_t), intent(inout) :: mci class(rng_t), intent(inout), allocatable :: rng end subroutine mci_import_rng <>= module subroutine mci_import_rng (mci, rng) class(mci_t), intent(inout) :: mci class(rng_t), intent(inout), allocatable :: rng call move_alloc (rng, mci%rng) end subroutine mci_import_rng @ %def mci_import_rng @ Activate or deactivate the timer. <>= procedure :: set_timer => mci_set_timer <>= module subroutine mci_set_timer (mci, active) class(mci_t), intent(inout) :: mci logical, intent(in) :: active end subroutine mci_set_timer <>= module subroutine mci_set_timer (mci, active) class(mci_t), intent(inout) :: mci logical, intent(in) :: active mci%use_timer = active end subroutine mci_set_timer @ %def mci_set_timer @ Start and stop signal for the timer, if active. The elapsed time can then be retrieved from the MCI record. <>= procedure :: start_timer => mci_start_timer procedure :: stop_timer => mci_stop_timer <>= module subroutine mci_start_timer (mci) class(mci_t), intent(inout) :: mci end subroutine mci_start_timer module subroutine mci_stop_timer (mci) class(mci_t), intent(inout) :: mci end subroutine mci_stop_timer <>= module subroutine mci_start_timer (mci) class(mci_t), intent(inout) :: mci if (mci%use_timer) call mci%timer%start () end subroutine mci_start_timer module subroutine mci_stop_timer (mci) class(mci_t), intent(inout) :: mci if (mci%use_timer) call mci%timer%stop () end subroutine mci_stop_timer @ %def mci_start_timer @ %def mci_stop_timer @ Sampler test. Evaluate the sampler a given number of times. Results are discarded, so we don't need the MCI instance which would record them. The evaluation channel is iterated, and the [[x]] parameters are randomly chosen. <>= procedure :: sampler_test => mci_sampler_test <>= module subroutine mci_sampler_test (mci, sampler, n_calls) class(mci_t), intent(inout) :: mci class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_calls end subroutine mci_sampler_test <>= module subroutine mci_sampler_test (mci, sampler, n_calls) class(mci_t), intent(inout) :: mci class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_calls real(default), dimension(:), allocatable :: x_in, f real(default), dimension(:,:), allocatable :: x_out real(default) :: val integer :: i, c allocate (x_in (mci%n_dim)) allocate (f (mci%n_channel)) allocate (x_out (mci%n_dim, mci%n_channel)) do i = 1, n_calls c = mod (i, mci%n_channel) + 1 call mci%rng%generate_array (x_in) call sampler%evaluate (c, x_in, val, x_out, f) end do end subroutine mci_sampler_test @ %def mci_sampler_test @ Integrate: this depends on the implementation. We foresee a pacify flag to take care of small numerical noise on different platforms. <>= procedure (mci_integrate), deferred :: integrate <>= abstract interface subroutine mci_integrate (mci, instance, sampler, & n_it, n_calls, results, pacify) import class(mci_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: pacify class(mci_results_t), intent(inout), optional :: results end subroutine mci_integrate end interface @ %def mci_integrate @ Event generation. Depending on the implementation, event generation may or may not require a previous integration pass. Instead of a black-box [[simulate]] method, we require an initializer, a finalizer, and procedures for generating a single event. This allows us to interface simulation event by event from the outside, and it facilitates the further processing of an event after successful generation. For integration, this is not necessary. The initializer has [[intent(inout)]] for the [[mci]] passed object. The reason is that the initializer can read integration results and grids from file, where the results can modify the [[mci]] record. <>= procedure (mci_prepare_simulation), deferred :: prepare_simulation @ %def mci_final_simulation <>= abstract interface subroutine mci_prepare_simulation (mci) import class(mci_t), intent(inout) :: mci end subroutine mci_prepare_simulation end interface @ %def mci_prepare_simulation @ The generated event will reside in in the [[instance]] object (overall results and weight) and in the [[sampler]] object (detailed data). In the real application, we can subsequently call methods of the [[sampler]] in order to further process the generated event. The [[target]] attributes are required by the VAMP implementation, which uses pointers to refer to the instance and sampler objects from within the integration function. <>= procedure (mci_generate), deferred :: generate_weighted_event procedure (mci_generate), deferred :: generate_unweighted_event @ %def mci_generate_weighted_event @ %def mci_generate_unweighted_event <>= abstract interface subroutine mci_generate (mci, instance, sampler) import class(mci_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler end subroutine mci_generate end interface @ %def mci_generate @ This is analogous, but we rebuild the event from the information stored in [[state]] instead of generating it. Note: currently unused outside of tests, might be deleted later. <>= procedure (mci_rebuild), deferred :: rebuild_event <>= abstract interface subroutine mci_rebuild (mci, instance, sampler, state) import class(mci_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state end subroutine mci_rebuild end interface @ %def mci_rebuild @ Pacify: reduce numerical noise. The base implementation does nothing. <>= procedure :: pacify => mci_pacify <>= module subroutine mci_pacify (object, efficiency_reset, error_reset) class(mci_t), intent(inout) :: object logical, intent(in), optional :: efficiency_reset, error_reset end subroutine mci_pacify <>= module subroutine mci_pacify (object, efficiency_reset, error_reset) class(mci_t), intent(inout) :: object logical, intent(in), optional :: efficiency_reset, error_reset end subroutine mci_pacify @ %def mci_pacify @ Return the value of the integral, error, efficiency, and time per call. <>= procedure :: get_integral => mci_get_integral procedure :: get_error => mci_get_error procedure :: get_efficiency => mci_get_efficiency procedure :: get_time => mci_get_time <>= module function mci_get_integral (mci) result (integral) class(mci_t), intent(in) :: mci real(default) :: integral end function mci_get_integral module function mci_get_error (mci) result (error) class(mci_t), intent(in) :: mci real(default) :: error end function mci_get_error module function mci_get_efficiency (mci) result (efficiency) class(mci_t), intent(in) :: mci real(default) :: efficiency end function mci_get_efficiency module function mci_get_time (mci) result (time) class(mci_t), intent(in) :: mci real(default) :: time end function mci_get_time <>= module function mci_get_integral (mci) result (integral) class(mci_t), intent(in) :: mci real(default) :: integral if (mci%integral_known) then integral = mci%integral else call msg_bug ("The integral is unknown. This is presumably a" // & "WHIZARD bug.") end if end function mci_get_integral module function mci_get_error (mci) result (error) class(mci_t), intent(in) :: mci real(default) :: error if (mci%error_known) then error = mci%error else error = 0 end if end function mci_get_error module function mci_get_efficiency (mci) result (efficiency) class(mci_t), intent(in) :: mci real(default) :: efficiency if (mci%efficiency_known) then efficiency = mci%efficiency else efficiency = 0 end if end function mci_get_efficiency module function mci_get_time (mci) result (time) class(mci_t), intent(in) :: mci real(default) :: time if (mci%use_timer) then time = mci%timer else time = 0 end if end function mci_get_time @ %def mci_get_integral @ %def mci_get_error @ %def mci_get_efficiency @ %def mci_get_time @ Return the MD5 sum of the configuration. This may be overridden in an extension, to return a different MD5 sum. <>= procedure :: get_md5sum => mci_get_md5sum <>= pure module function mci_get_md5sum (mci) result (md5sum) class(mci_t), intent(in) :: mci character(32) :: md5sum end function mci_get_md5sum <>= pure module function mci_get_md5sum (mci) result (md5sum) class(mci_t), intent(in) :: mci character(32) :: md5sum md5sum = mci%md5sum end function mci_get_md5sum @ %def mci_get_md5sum @ \subsection{MCI instance} The base type contains an array of channel weights. The value [[mci_weight]] is the combined MCI weight that corresponds to a particular sampling point. For convenience, we also store the [[x]] and Jacobian values for this sampling point. <>= public :: mci_instance_t <>= type, abstract :: mci_instance_t logical :: valid = .false. real(default), dimension(:), allocatable :: w real(default), dimension(:), allocatable :: f real(default), dimension(:,:), allocatable :: x integer :: selected_channel = 0 real(default) :: mci_weight = 0 real(default) :: integrand = 0 logical :: negative_weights = .false. integer :: n_dropped = 0 contains <> end type mci_instance_t @ %def mci_instance_t @ Output: deferred <>= procedure (mci_instance_write), deferred :: write <>= abstract interface subroutine mci_instance_write (object, unit, pacify) import class(mci_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify end subroutine mci_instance_write end interface @ %def mci_instance_write @ A finalizer, just in case. <>= procedure (mci_instance_final), deferred :: final <>= abstract interface subroutine mci_instance_final (object) import class(mci_instance_t), intent(inout) :: object end subroutine mci_instance_final end interface @ %def mci_instance_final @ Init: basic initializer for the arrays, otherwise deferred. Assigning the [[mci]] object is also deferred, because it depends on the concrete type. The weights are initialized with an uniform normalized value. <>= procedure (mci_instance_base_init), deferred :: init procedure :: base_init => mci_instance_base_init <>= module subroutine mci_instance_base_init (mci_instance, mci) class(mci_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci end subroutine mci_instance_base_init <>= module subroutine mci_instance_base_init (mci_instance, mci) class(mci_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci allocate (mci_instance%w (mci%n_channel)) allocate (mci_instance%f (mci%n_channel)) allocate (mci_instance%x (mci%n_dim, mci%n_channel)) if (mci%n_channel > 0) then call mci_instance%set_channel_weights & (spread (1._default, dim=1, ncopies=mci%n_channel)) end if mci_instance%f = 0 mci_instance%x = 0 end subroutine mci_instance_base_init @ %def mci_instance_base_init @ Explicitly set the array of channel weights. <>= procedure :: set_channel_weights => mci_instance_set_channel_weights <>= - module subroutine mci_instance_set_channel_weights & + module subroutine mci_instance_set_channel_weights & (mci_instance, weights, sum_non_zero) class(mci_instance_t), intent(inout) :: mci_instance real(default), dimension(:), intent(in) :: weights logical, intent(out), optional :: sum_non_zero end subroutine mci_instance_set_channel_weights <>= - module subroutine mci_instance_set_channel_weights & + module subroutine mci_instance_set_channel_weights & (mci_instance, weights, sum_non_zero) class(mci_instance_t), intent(inout) :: mci_instance real(default), dimension(:), intent(in) :: weights logical, intent(out), optional :: sum_non_zero real(default) :: wsum wsum = sum (weights) if (wsum /= 0) then mci_instance%w = weights / wsum if (present (sum_non_zero)) sum_non_zero = .true. else if (present (sum_non_zero)) sum_non_zero = .false. call msg_warning ("MC sampler initialization:& & sum of channel weights is zero") end if end subroutine mci_instance_set_channel_weights @ %def mci_instance_set_channel_weights @ Compute the overall weight factor for a configuration of $x$ values and Jacobians $f$. The $x$ values come in [[n_channel]] rows with [[n_dim]] entries each. The $f$ factors constitute an array with [[n_channel]] entries. We assume that the $x$ and $f$ arrays are already stored inside the MC instance. The result is also stored there. <>= procedure (mci_instance_compute_weight), deferred :: compute_weight <>= abstract interface subroutine mci_instance_compute_weight (mci, c) import class(mci_instance_t), intent(inout) :: mci integer, intent(in) :: c end subroutine mci_instance_compute_weight end interface @ %def mci_instance_compute_weight @ Record the integrand as returned by the sampler. Depending on the implementation, this may merely copy the value, or do more complicated things. We may need the MCI weight for the actual computations, so this should be called after the previous routine. <>= procedure (mci_instance_record_integrand), deferred :: record_integrand <>= abstract interface subroutine mci_instance_record_integrand (mci, integrand) import class(mci_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand end subroutine mci_instance_record_integrand end interface @ %def mci_instance_record_integrand @ Sample a point directly: evaluate the sampler, then compute the weight and the weighted integrand. Finally, record the integrand within the MCI instance. If a signal (interrupt) was raised recently, we abort the calculation before entering the sampler. Thus, a previous calculation will have completed and any data are already recorded, but any new point can be discarded. If the [[abort]] flag is present, we may delay the interrupt, so we can do some cleanup. <>= procedure :: evaluate => mci_instance_evaluate <>= module subroutine mci_instance_evaluate (mci, sampler, c, x) class(mci_instance_t), intent(inout) :: mci class(mci_sampler_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x end subroutine mci_instance_evaluate <>= module subroutine mci_instance_evaluate (mci, sampler, c, x) class(mci_instance_t), intent(inout) :: mci class(mci_sampler_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x real(default) :: val call sampler%evaluate (c, x, val, mci%x, mci%f) mci%valid = sampler%is_valid () if (mci%valid) then call mci%compute_weight (c) call mci%record_integrand (val) end if end subroutine mci_instance_evaluate @ %def mci_instance_evaluate @ Initiate and terminate simulation. In contrast to integration, we implement these as methods of the process instance, since the [[mci]] configuration object is unchanged. The safety factor reduces the acceptance probability for unweighted events. The implementation of this feature depends on the concrete type. <>= procedure (mci_instance_init_simulation), deferred :: init_simulation procedure (mci_instance_final_simulation), deferred :: final_simulation <>= abstract interface subroutine mci_instance_init_simulation (instance, safety_factor) import class(mci_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor end subroutine mci_instance_init_simulation end interface abstract interface subroutine mci_instance_final_simulation (instance) import class(mci_instance_t), intent(inout) :: instance end subroutine mci_instance_final_simulation end interface @ %def mci_instance_init_simulation mci_instance_final_simulation @ Assuming that the sampler is in a completely defined state, just extract the data that [[evaluate]] would compute. Also record the integrand. <>= procedure :: fetch => mci_instance_fetch <>= module subroutine mci_instance_fetch (mci, sampler, c) class(mci_instance_t), intent(inout) :: mci class(mci_sampler_t), intent(in) :: sampler integer, intent(in) :: c end subroutine mci_instance_fetch <>= module subroutine mci_instance_fetch (mci, sampler, c) class(mci_instance_t), intent(inout) :: mci class(mci_sampler_t), intent(in) :: sampler integer, intent(in) :: c real(default) :: val mci%valid = sampler%is_valid () if (mci%valid) then call sampler%fetch (val, mci%x, mci%f) call mci%compute_weight (c) call mci%record_integrand (val) end if end subroutine mci_instance_fetch @ %def mci_instance_fetch @ The value, i.e., the weighted integrand, is the integrand (which should be taken as-is from the sampler) multiplied by the MCI weight. <>= procedure :: get_value => mci_instance_get_value <>= module function mci_instance_get_value (mci) result (value) class(mci_instance_t), intent(in) :: mci real(default) :: value end function mci_instance_get_value <>= module function mci_instance_get_value (mci) result (value) class(mci_instance_t), intent(in) :: mci real(default) :: value if (mci%valid) then value = mci%integrand * mci%mci_weight else value = 0 end if end function mci_instance_get_value @ %def mci_instance_get_value @ This is an extra routine. By default, the event weight is equal to the value returned by the previous routine. However, if we select a channel for event generation not just based on the channel weights, the event weight has to account for this bias, so the event weight that applies to event generation is different. In that case, we should override the default routine. <>= procedure :: get_event_weight => mci_instance_get_value @ %def mci_instance_get_event_weight @ Excess weight can occur during unweighted event generation, if the assumed maximum value of the integrand is too small. This excess should be normalized in the same way as the event weight above (which for unweighted events becomes unity). <>= procedure (mci_instance_get_event_excess), deferred :: get_event_excess <>= abstract interface function mci_instance_get_event_excess (mci) result (excess) import class(mci_instance_t), intent(in) :: mci real(default) :: excess end function mci_instance_get_event_excess end interface @ %def mci_instance_get_event_excess @ Dropped events (i.e., events with zero weight that are not retained) are counted within the [[mci_instance]] object. <>= procedure :: get_n_event_dropped => mci_instance_get_n_event_dropped procedure :: reset_n_event_dropped => mci_instance_reset_n_event_dropped procedure :: record_event_dropped => mci_instance_record_event_dropped <>= module function mci_instance_get_n_event_dropped (mci) result (n_dropped) class(mci_instance_t), intent(in) :: mci integer :: n_dropped end function mci_instance_get_n_event_dropped module subroutine mci_instance_reset_n_event_dropped (mci) class(mci_instance_t), intent(inout) :: mci end subroutine mci_instance_reset_n_event_dropped module subroutine mci_instance_record_event_dropped (mci) class(mci_instance_t), intent(inout) :: mci end subroutine mci_instance_record_event_dropped <>= module function mci_instance_get_n_event_dropped (mci) result (n_dropped) class(mci_instance_t), intent(in) :: mci integer :: n_dropped n_dropped = mci%n_dropped end function mci_instance_get_n_event_dropped module subroutine mci_instance_reset_n_event_dropped (mci) class(mci_instance_t), intent(inout) :: mci mci%n_dropped = 0 end subroutine mci_instance_reset_n_event_dropped module subroutine mci_instance_record_event_dropped (mci) class(mci_instance_t), intent(inout) :: mci mci%n_dropped = mci%n_dropped + 1 end subroutine mci_instance_record_event_dropped @ %def mci_instance_get_n_event_dropped @ %def mci_instance_reset_n_event_dropped @ %def mci_instance_record_event_dropped @ \subsection{MCI state} This object can hold the relevant information that allows us to reconstruct the MCI instance without re-evaluating the sampler completely. We store the [[x_in]] MC input parameter set, which coincides with the section of the complete [[x]] array that belongs to a particular channel. We also store the MC function value. When we want to reconstruct the state, we can use the input array to recover the complete [[x]] and [[f]] arrays (i.e., the kinematics), but do not need to recompute the MC function value (the dynamics). The [[mci_state_t]] may be extended, to allow storing/recalling more information. In that case, we would override the type-bound procedures. However, the base type is also a concrete type and self-contained. <>= public :: mci_state_t <>= type :: mci_state_t integer :: selected_channel = 0 real(default), dimension(:), allocatable :: x_in real(default) :: val contains <> end type mci_state_t @ %def mci_state_t @ Output: <>= procedure :: write => mci_state_write <>= module subroutine mci_state_write (object, unit) class(mci_state_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine mci_state_write <>= module subroutine mci_state_write (object, unit) class(mci_state_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "MCI state:" write (u, "(3x,A,I0)") "Channel = ", object%selected_channel write (u, "(3x,A,999(1x,F12.10))") "x (in) =", object%x_in write (u, "(3x,A,ES19.12)") "Integrand = ", object%val end subroutine mci_state_write @ %def mci_state_write @ To store the object, we take the relevant section of the [[x]] array. The channel used for storing data is taken from the [[instance]] object, but it could be arbitrary in principle. <>= procedure :: store => mci_instance_store <>= module subroutine mci_instance_store (mci, state) class(mci_instance_t), intent(in) :: mci class(mci_state_t), intent(out) :: state end subroutine mci_instance_store <>= module subroutine mci_instance_store (mci, state) class(mci_instance_t), intent(in) :: mci class(mci_state_t), intent(out) :: state state%selected_channel = mci%selected_channel allocate (state%x_in (size (mci%x, 1))) state%x_in = mci%x(:,mci%selected_channel) state%val = mci%integrand end subroutine mci_instance_store @ %def mci_instance_store @ Recalling the state, we must consult the sampler in order to fully reconstruct the [[x]] and [[f]] arrays. The integrand value is known, and we also give it to the sampler, bypassing evaluation. The final steps are equivalent to the [[evaluate]] method above. <>= procedure :: recall => mci_instance_recall <>= module subroutine mci_instance_recall (mci, sampler, state) class(mci_instance_t), intent(inout) :: mci class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state end subroutine mci_instance_recall <>= module subroutine mci_instance_recall (mci, sampler, state) class(mci_instance_t), intent(inout) :: mci class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state if (size (state%x_in) == size (mci%x, 1) & .and. state%selected_channel <= size (mci%x, 2)) then call sampler%rebuild (state%selected_channel, & state%x_in, state%val, mci%x, mci%f) call mci%compute_weight (state%selected_channel) call mci%record_integrand (state%val) else call msg_fatal ("Recalling event: mismatch in channel or dimension") end if end subroutine mci_instance_recall @ %def mci_instance_recall @ \subsection{MCI sampler} A sampler is an object that implements a multi-channel parameterization of the unit hypercube. Specifically, it is able to compute, given a channel and a set of $x$ MC parameter values, the complete set of $x$ values and associated Jacobian factors $f$ for all channels. Furthermore, the sampler should return a single real value, the integrand, for the given point in the hypercube. It must implement a method [[evaluate]] for performing the above computations. <>= public :: mci_sampler_t <>= type, abstract :: mci_sampler_t contains <> end type mci_sampler_t @ %def mci_sampler_t @ Output, deferred to the implementation. <>= procedure (mci_sampler_write), deferred :: write <>= abstract interface subroutine mci_sampler_write (object, unit, testflag) import class(mci_sampler_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine mci_sampler_write end interface @ %def mci_sampler_write @ The evaluation routine. Input is the channel index [[c]] and the one-dimensional parameter array [[x_in]]. Output are the integrand value [[val]], the two-dimensional parameter array [[x]] and the Jacobian array [[f]]. <>= procedure (mci_sampler_evaluate), deferred :: evaluate <>= abstract interface subroutine mci_sampler_evaluate (sampler, c, x_in, val, x, f) import class(mci_sampler_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f end subroutine mci_sampler_evaluate end interface @ %def mci_sampler_evaluate @ Query the validity of the sampling point. Can be called after [[evaluate]]. <>= procedure (mci_sampler_is_valid), deferred :: is_valid <>= abstract interface function mci_sampler_is_valid (sampler) result (valid) import class(mci_sampler_t), intent(in) :: sampler logical :: valid end function mci_sampler_is_valid end interface @ %def mci_sampler_is_valid @ The shortcut. Again, the channel index [[c]] and the parameter array [[x_in]] are input. However, we also provide the integrand value [[val]], and we just require that the complete parameter array [[x]] and Jacobian array [[f]] are recovered. <>= procedure (mci_sampler_rebuild), deferred :: rebuild <>= abstract interface subroutine mci_sampler_rebuild (sampler, c, x_in, val, x, f) import class(mci_sampler_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f end subroutine mci_sampler_rebuild end interface @ %def mci_sampler_rebuild @ This routine should extract the important data from a sampler that has been filled by other means. We fetch the integrand value [[val]], the two-dimensional parameter array [[x]] and the Jacobian array [[f]]. <>= procedure (mci_sampler_fetch), deferred :: fetch <>= abstract interface subroutine mci_sampler_fetch (sampler, val, x, f) import class(mci_sampler_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f end subroutine mci_sampler_fetch end interface @ %def mci_sampler_fetch @ \subsection{Results record} This is an abstract type which allows us to implement callback: each integration results can optionally be recorded to an instance of this object. The actual object may store a new result, average results, etc. It may also display a result on-line or otherwise, whenever the [[record]] method is called. <>= public :: mci_results_t <>= type, abstract :: mci_results_t contains <> end type mci_results_t @ %def mci_results_t @ The output routine is deferred. We provide an extra [[verbose]] flag, which could serve any purpose. <>= procedure (mci_results_write), deferred :: write procedure (mci_results_write_verbose), deferred :: write_verbose <>= abstract interface subroutine mci_results_write (object, unit, suppress) import class(mci_results_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: suppress end subroutine mci_results_write subroutine mci_results_write_verbose (object, unit) import class(mci_results_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine mci_results_write_verbose end interface @ %def mci_results_write @ This is the generic [[record]] method, which can be called directly from the integrator. The [[record_extended]] procedure store additionally the valid calls, positive and negative efficiency. <>= generic :: record => record_simple, record_extended procedure (mci_results_record_simple), deferred :: record_simple procedure (mci_results_record_extended), deferred :: record_extended <>= abstract interface subroutine mci_results_record_simple (object, n_it, & n_calls, integral, error, efficiency, chain_weights, suppress) import class(mci_results_t), intent(inout) :: object integer, intent(in) :: n_it integer, intent(in) :: n_calls real(default), intent(in) :: integral real(default), intent(in) :: error real(default), intent(in) :: efficiency real(default), dimension(:), intent(in), optional :: chain_weights logical, intent(in), optional :: suppress end subroutine mci_results_record_simple subroutine mci_results_record_extended (object, n_it, n_calls,& & n_calls_valid, integral, error, efficiency, efficiency_pos,& & efficiency_neg, chain_weights, suppress) import class(mci_results_t), intent(inout) :: object integer, intent(in) :: n_it integer, intent(in) :: n_calls integer, intent(in) :: n_calls_valid real(default), intent(in) :: integral real(default), intent(in) :: error real(default), intent(in) :: efficiency real(default), intent(in) :: efficiency_pos real(default), intent(in) :: efficiency_neg real(default), dimension(:), intent(in), optional :: chain_weights logical, intent(in), optional :: suppress end subroutine mci_results_record_extended end interface @ %def mci_results_record @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[mci_base_ut.f90]]>>= <> module mci_base_ut use unit_tests use mci_base_uti <> <> <> contains <> end module mci_base_ut @ %def mci_base_ut @ <<[[mci_base_uti.f90]]>>= <> module mci_base_uti <> use io_units use diagnostics use phs_base use rng_base use mci_base use rng_base_ut, only: rng_test_t <> <> <> <> contains <> end module mci_base_uti @ %def mci_base_ut @ API: driver for the unit tests below. <>= public :: mci_base_test <>= subroutine mci_base_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine mci_base_test @ %def mci_base_test @ \subsubsection{Test implementation of the configuration type} The concrete type contains the number of requested calls and the integral result, to be determined. The [[max_factor]] entry is set for the actual test integration, where the integrand is not unity but some other constant value. This value should be set here, such that the actual maximum of the integrand is known when vetoing unweighted events. <>= public :: mci_test_t <>= type, extends (mci_t) :: mci_test_t integer :: divisions = 0 integer :: tries = 0 real(default) :: max_factor = 1 contains procedure :: final => mci_test_final procedure :: write => mci_test_write procedure :: startup_message => mci_test_startup_message procedure :: write_log_entry => mci_test_write_log_entry procedure :: compute_md5sum => mci_test_compute_md5sum procedure :: declare_flat_dimensions => mci_test_ignore_flat_dimensions procedure :: declare_equivalences => mci_test_ignore_equivalences procedure :: set_divisions => mci_test_set_divisions procedure :: set_max_factor => mci_test_set_max_factor procedure :: allocate_instance => mci_test_allocate_instance procedure :: integrate => mci_test_integrate procedure :: prepare_simulation => mci_test_ignore_prepare_simulation procedure :: generate_weighted_event => mci_test_generate_weighted_event procedure :: generate_unweighted_event => & mci_test_generate_unweighted_event procedure :: rebuild_event => mci_test_rebuild_event end type mci_test_t @ %def mci_test_t @ Finalizer: base version is sufficient <>= subroutine mci_test_final (object) class(mci_test_t), intent(inout) :: object call object%base_final () end subroutine mci_test_final @ %def mci_test_final @ Output: trivial <>= subroutine mci_test_write (object, unit, pacify, md5sum_version) class(mci_test_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Test integrator:" call object%base_write (u, pacify, md5sum_version) if (object%divisions /= 0) then write (u, "(3x,A,I0)") "Number of divisions = ", object%divisions end if if (allocated (object%rng)) call object%rng%write (u) end subroutine mci_test_write @ %def mci_test_write @ Short version. <>= subroutine mci_test_startup_message (mci, unit, n_calls) class(mci_test_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls call mci%base_startup_message (unit = unit, n_calls = n_calls) write (msg_buffer, "(A,1x,I0,1x,A)") & "Integrator: Test:", mci%divisions, "divisions" call msg_message (unit = unit) end subroutine mci_test_startup_message @ %def mci_test_startup_message @ Log entry: nothing. <>= subroutine mci_test_write_log_entry (mci, u) class(mci_test_t), intent(in) :: mci integer, intent(in) :: u end subroutine mci_test_write_log_entry @ %def mci_test_write_log_entry @ Compute MD5 sum: nothing. <>= subroutine mci_test_compute_md5sum (mci, pacify) class(mci_test_t), intent(inout) :: mci logical, intent(in), optional :: pacify end subroutine mci_test_compute_md5sum @ %def mci_test_compute_md5sum @ This is a no-op for the test integrator. <>= subroutine mci_test_ignore_flat_dimensions (mci, dim_flat) class(mci_test_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat end subroutine mci_test_ignore_flat_dimensions @ %def mci_test_ignore_flat_dimensions @ Ditto. <>= subroutine mci_test_ignore_equivalences (mci, channel, dim_offset) class(mci_test_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset end subroutine mci_test_ignore_equivalences @ %def mci_test_ignore_equivalences @ Set the number of divisions to a nonzero value. <>= subroutine mci_test_set_divisions (object, divisions) class(mci_test_t), intent(inout) :: object integer, intent(in) :: divisions object%divisions = divisions end subroutine mci_test_set_divisions @ %def mci_test_set_divisions @ Set the maximum factor (default is 1). <>= subroutine mci_test_set_max_factor (object, max_factor) class(mci_test_t), intent(inout) :: object real(default), intent(in) :: max_factor object%max_factor = max_factor end subroutine mci_test_set_max_factor @ %def mci_test_set_max_factor @ Allocate instance with matching type. <>= subroutine mci_test_allocate_instance (mci, mci_instance) class(mci_test_t), intent(in) :: mci class(mci_instance_t), intent(out), pointer :: mci_instance allocate (mci_test_instance_t :: mci_instance) end subroutine mci_test_allocate_instance @ %def mci_test_allocate_instance @ Integrate: sample at the midpoints of uniform bits and add the results. We implement this for one and for two dimensions. In the latter case, we scan over two channels and multiply with the channel weights. The arguments [[n_it]] and [[n_calls]] are ignored in this implementations. The test integrator does not set error or efficiency, so those will remain undefined. <>= subroutine mci_test_integrate (mci, instance, sampler, & n_it, n_calls, results, pacify) class(mci_test_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: pacify class(mci_results_t), intent(inout), optional :: results real(default), dimension(:), allocatable :: integral real(default), dimension(:), allocatable :: x integer :: i, j, c select type (instance) type is (mci_test_instance_t) allocate (integral (mci%n_channel)) integral = 0 allocate (x (mci%n_dim)) select case (mci%n_dim) case (1) do c = 1, mci%n_channel do i = 1, mci%divisions x(1) = (i - 0.5_default) / mci%divisions call instance%evaluate (sampler, c, x) integral(c) = integral(c) + instance%get_value () end do end do mci%integral = dot_product (instance%w, integral) & / mci%divisions mci%integral_known = .true. case (2) do c = 1, mci%n_channel do i = 1, mci%divisions x(1) = (i - 0.5_default) / mci%divisions do j = 1, mci%divisions x(2) = (j - 0.5_default) / mci%divisions call instance%evaluate (sampler, c, x) integral(c) = integral(c) + instance%get_value () end do end do end do mci%integral = dot_product (instance%w, integral) & / mci%divisions / mci%divisions mci%integral_known = .true. end select if (present (results)) then call results%record (n_it, n_calls, & mci%integral, mci%error, & efficiency = 0._default) end if end select end subroutine mci_test_integrate @ %def mci_test_integrate @ Simulation initializer and finalizer: nothing to do here. <>= subroutine mci_test_ignore_prepare_simulation (mci) class(mci_test_t), intent(inout) :: mci end subroutine mci_test_ignore_prepare_simulation @ %def mci_test_ignore_prepare_simulation @ Event generator. We use mock random numbers for first selecting the channel and then setting the $x$ values. The results reside in the state of [[instance]] and [[sampler]]. <>= subroutine mci_test_generate_weighted_event (mci, instance, sampler) class(mci_test_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler real(default) :: r real(default), dimension(:), allocatable :: x integer :: c select type (instance) type is (mci_test_instance_t) allocate (x (mci%n_dim)) select case (mci%n_channel) case (1) c = 1 call mci%rng%generate (x(1)) case (2) call mci%rng%generate (r) if (r < instance%w(1)) then c = 1 else c = 2 end if call mci%rng%generate (x) end select call instance%evaluate (sampler, c, x) end select end subroutine mci_test_generate_weighted_event @ %def mci_test_generate_weighted_event @ For unweighted events, we generate weighted events and apply a simple rejection step to the relative event weight, until an event passes. (This might result in an endless loop if we happen to be in sync with the mock random generator cycle. Therefore, limit the number of tries.) <>= subroutine mci_test_generate_unweighted_event (mci, instance, sampler) class(mci_test_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler real(default) :: r integer :: i select type (instance) type is (mci_test_instance_t) mci%tries = 0 do i = 1, 10 call mci%generate_weighted_event (instance, sampler) mci%tries = mci%tries + 1 call mci%rng%generate (r) if (r < instance%rel_value) exit end do end select end subroutine mci_test_generate_unweighted_event @ %def mci_test_generate_unweighted_event @ Here, we rebuild the event from the state without consulting the rng. <>= subroutine mci_test_rebuild_event (mci, instance, sampler, state) class(mci_test_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state select type (instance) type is (mci_test_instance_t) call instance%recall (sampler, state) end select end subroutine mci_test_rebuild_event @ %def mci_test_rebuild_event @ \subsubsection{Instance of the test MCI type} This instance type simulates the VAMP approach. We implement the VAMP multi-channel formula, but keep the channel-specific probability functions $g_i$ smooth and fixed. We also keep the weights fixed. The setup is as follows: we have $n$ mappings of the unit hypercube \begin{equation} x = x (x^{(k)}) \qquad \text{where $x=(x_1,\ldots)$}. \end{equation} The Jacobian factors are the determinants \begin{equation} f^{(k)}(x^{(k)}) = \left|\frac{\partial x}{\partial x^{(k)}}\right| \end{equation} We introduce arbitrary probability functions \begin{equation} g^{(k)}(x^{(k)}) \qquad \text{with}\quad \int dx^{(k)} g^{(k)}(x^{(k)}) = 1 \end{equation} and weights \begin{equation} w_k \qquad \text{with}\quad \sum_k w_k = 1 \end{equation} and construct the joint probability function \begin{equation} g(x) = \sum_k w_k\frac{g^{(k)}(x^{(k)}(x))}{f^{(k)}(x^{(k)}(x))} \end{equation} which also satisfies \begin{equation} \int g(x)\,dx = 1. \end{equation} The algorithm implements a resolution of unity as follows \begin{align} 1 &= \int dx = \int\frac{g(x)}{g(x)} dx \nonumber\\ &= \sum w_k \int \frac{g^{(k)}(x^{(k)}(x))}{f^{(k)}(x^{(k)}(x))} \,\frac{dx}{g(x)} \nonumber\\ &= \sum w_k \int g^{(k)}(x^{(k)}) \frac{dx^{(k)}}{g(x(x^{(k)}))} \end{align} where each of the integrals in the sum is evaluated using the channel-specific variables $x^{(k)}$. We provide two examples: (1) trivial with one channel, one dimension, and all functions unity and (2) two channels and two dimensions with \begin{align} x (x^{(1)}) &= (x^{(1)}_1, x^{(1)}_2) \nonumber\\ x (x^{(2)}) &= (x^{(2)}_1{}^2, x^{(2)}_2) \end{align} hence \begin{align} f^{(1)}&\equiv 1, &f^{(2)}(x^{(2)}) &= 2x^{(2)}_1 \end{align} The probability functions are \begin{align} g^{(1)}&\equiv 1, &g^{(2)}(x^{(2)}) = 2 x^{(2)}_2 \end{align} In the concrete implementation of the integrator instance we store values for the channel probabilities $g_i$ and the accumulated probability $g$. We also store the result (product of integrand and MCI weight), the expected maximum for the result in each channel. <>= public :: mci_test_instance_t <>= type, extends (mci_instance_t) :: mci_test_instance_t type(mci_test_t), pointer :: mci => null () real(default) :: g = 0 real(default), dimension(:), allocatable :: gi real(default) :: value = 0 real(default) :: rel_value = 0 real(default), dimension(:), allocatable :: max contains procedure :: write => mci_test_instance_write procedure :: final => mci_test_instance_final procedure :: init => mci_test_instance_init procedure :: compute_weight => mci_test_instance_compute_weight procedure :: record_integrand => mci_test_instance_record_integrand procedure :: init_simulation => mci_test_instance_init_simulation procedure :: final_simulation => mci_test_instance_final_simulation procedure :: get_event_excess => mci_test_instance_get_event_excess end type mci_test_instance_t @ %def mci_test_instance_t @ Output: trivial <>= subroutine mci_test_instance_write (object, unit, pacify) class(mci_test_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify integer :: u, c u = given_output_unit (unit) write (u, "(1x,A,ES13.7)") "Result value = ", object%value write (u, "(1x,A,ES13.7)") "Rel. weight = ", object%rel_value write (u, "(1x,A,ES13.7)") "Integrand = ", object%integrand write (u, "(1x,A,ES13.7)") "MCI weight = ", object%mci_weight write (u, "(3x,A,I0)") "c = ", object%selected_channel write (u, "(3x,A,ES13.7)") "g = ", object%g write (u, "(1x,A)") "Channel parameters:" do c = 1, object%mci%n_channel write (u, "(1x,I0,A,4(1x,ES13.7))") c, ": w/f/g/m =", & object%w(c), object%f(c), object%gi(c), object%max(c) write (u, "(4x,A,9(1x,F9.7))") "x =", object%x(:,c) end do end subroutine mci_test_instance_write @ %def mci_test_instance_write @ The finalizer is empty. <>= subroutine mci_test_instance_final (object) class(mci_test_instance_t), intent(inout) :: object end subroutine mci_test_instance_final @ %def mci_test_instance_final @ Initializer. We make use of the analytical result that the maximum of the weighted integrand, in each channel, is equal to $1$ (one-dimensional case) and $2$ (two-dimensional case), respectively. <>= subroutine mci_test_instance_init (mci_instance, mci) class(mci_test_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci call mci_instance%base_init (mci) select type (mci) type is (mci_test_t) mci_instance%mci => mci end select allocate (mci_instance%gi (mci%n_channel)) mci_instance%gi = 0 allocate (mci_instance%max (mci%n_channel)) select case (mci%n_channel) case (1) mci_instance%max = 1._default case (2) mci_instance%max = 2._default end select end subroutine mci_test_instance_init @ %def mci_test_instance_init @ Compute weight: we implement the VAMP multi-channel formula. The channel probabilities [[gi]] are predefined functions. <>= subroutine mci_test_instance_compute_weight (mci, c) class(mci_test_instance_t), intent(inout) :: mci integer, intent(in) :: c integer :: i mci%selected_channel = c select case (mci%mci%n_dim) case (1) mci%gi(1) = 1 case (2) mci%gi(1) = 1 mci%gi(2) = 2 * mci%x(2,2) end select mci%g = 0 do i = 1, mci%mci%n_channel mci%g = mci%g + mci%w(i) * mci%gi(i) / mci%f(i) end do mci%mci_weight = mci%gi(c) / mci%g end subroutine mci_test_instance_compute_weight @ %def mci_test_instance_compute_weight @ Record the integrand. Apply the Jacobian weight to get the absolute value. Divide by the channel maximum and by any overall factor to get the value relative to the maximum. <>= subroutine mci_test_instance_record_integrand (mci, integrand) class(mci_test_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand mci%integrand = integrand mci%value = mci%integrand * mci%mci_weight mci%rel_value = mci%value / mci%max(mci%selected_channel) & / mci%mci%max_factor end subroutine mci_test_instance_record_integrand @ %def mci_test_instance_record_integrand @ Nothing to do here. <>= subroutine mci_test_instance_init_simulation (instance, safety_factor) class(mci_test_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor end subroutine mci_test_instance_init_simulation subroutine mci_test_instance_final_simulation (instance) class(mci_test_instance_t), intent(inout) :: instance end subroutine mci_test_instance_final_simulation @ %def mci_test_instance_init_simulation @ %def mci_test_instance_final_simulation @ Return always zero. <>= function mci_test_instance_get_event_excess (mci) result (excess) class(mci_test_instance_t), intent(in) :: mci real(default) :: excess excess = 0 end function mci_test_instance_get_event_excess @ %def mci_test_instance_get_event_excess @ \subsubsection{Test sampler} The test sampler implements a fixed configuration, either trivial (one-channel, one-dimension), or slightly nontrivial (two-channel, two-dimension). In the second channel, the first parameter is mapped according to $x_1 = x^{(2)}_1{}^2$, so we have $f^{(2)}(x^{(2)}) = 2x^{(2)}_1$. For display purposes, we store the return values inside the object. This is not strictly necessary. <>= type, extends (mci_sampler_t) :: test_sampler_t real(default) :: integrand = 0 integer :: selected_channel = 0 real(default), dimension(:,:), allocatable :: x real(default), dimension(:), allocatable :: f contains procedure :: init => test_sampler_init procedure :: write => test_sampler_write procedure :: compute => test_sampler_compute procedure :: is_valid => test_sampler_is_valid procedure :: evaluate => test_sampler_evaluate procedure :: rebuild => test_sampler_rebuild procedure :: fetch => test_sampler_fetch end type test_sampler_t @ %def test_sampler_t <>= subroutine test_sampler_init (sampler, n) class(test_sampler_t), intent(out) :: sampler integer, intent(in) :: n allocate (sampler%x (n, n)) allocate (sampler%f (n)) end subroutine test_sampler_init @ %def test_sampler_init @ Output <>= subroutine test_sampler_write (object, unit, testflag) class(test_sampler_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u, c u = given_output_unit (unit) write (u, "(1x,A)") "Test sampler:" write (u, "(3x,A,ES13.7)") "Integrand = ", object%integrand write (u, "(3x,A,I0)") "Channel = ", object%selected_channel do c = 1, size (object%f) write (u, "(1x,I0,':',1x,A,ES13.7)") c, "f = ", object%f(c) write (u, "(4x,A,9(1x,F9.7))") "x =", object%x(:,c) end do end subroutine test_sampler_write @ %def test_sampler_write @ Compute $x$ and Jacobians, given the input parameter array. This is called both by [[evaluate]] and [[rebuild]]. <>= subroutine test_sampler_compute (sampler, c, x_in) class(test_sampler_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in sampler%selected_channel = c select case (size (sampler%f)) case (1) sampler%x(:,1) = x_in sampler%f = 1 case (2) select case (c) case (1) sampler%x(:,1) = x_in sampler%x(1,2) = sqrt (x_in(1)) sampler%x(2,2) = x_in(2) case (2) sampler%x(1,1) = x_in(1) ** 2 sampler%x(2,1) = x_in(2) sampler%x(:,2) = x_in end select sampler%f(1) = 1 sampler%f(2) = 2 * sampler%x(1,2) end select end subroutine test_sampler_compute @ %def test_sampler_kineamtics @ The point is always valid. <>= function test_sampler_is_valid (sampler) result (valid) class(test_sampler_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_is_valid @ %def test_sampler_is_valid @ The integrand is always equal to 1. <>= subroutine test_sampler_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) sampler%integrand = 1 val = sampler%integrand x = sampler%x f = sampler%f end subroutine test_sampler_evaluate @ %def test_sampler_evaluate @ Construct kinematics from the input $x$ array. Set the integrand instead of evaluating it. <>= subroutine test_sampler_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) sampler%integrand = val x = sampler%x f = sampler%f end subroutine test_sampler_rebuild @ %def test_sampler_rebuild @ Recall contents. <>= subroutine test_sampler_fetch (sampler, val, x, f) class(test_sampler_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%integrand x = sampler%x f = sampler%f end subroutine test_sampler_fetch @ %def test_sampler_fetch @ \subsubsection{Test results object} This mock object just stores and displays the current result. <>= type, extends (mci_results_t) :: mci_test_results_t integer :: n_it = 0 integer :: n_calls = 0 real(default) :: integral = 0 real(default) :: error = 0 real(default) :: efficiency = 0 contains <> end type mci_test_results_t @ %def mci_test_results_t @ Output. <>= procedure :: write => mci_test_results_write procedure :: write_verbose => mci_test_results_write_verbose <>= subroutine mci_test_results_write (object, unit, suppress) class(mci_test_results_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: suppress integer :: u u = given_output_unit (unit) write (u, "(3x,A,1x,I0)") "Iterations = ", object%n_it write (u, "(3x,A,1x,I0)") "Calls = ", object%n_calls write (u, "(3x,A,1x,F12.10)") "Integral = ", object%integral write (u, "(3x,A,1x,F12.10)") "Error = ", object%error write (u, "(3x,A,1x,F12.10)") "Efficiency = ", object%efficiency end subroutine mci_test_results_write subroutine mci_test_results_write_verbose (object, unit) class(mci_test_results_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A,1x,I0)") "Iterations = ", object%n_it write (u, "(3x,A,1x,I0)") "Calls = ", object%n_calls write (u, "(3x,A,1x,F12.10)") "Integral = ", object%integral write (u, "(3x,A,1x,F12.10)") "Error = ", object%error write (u, "(3x,A,1x,F12.10)") "Efficiency = ", object%efficiency end subroutine mci_test_results_write_verbose @ %def mci_test_results_write @ Record result. <>= procedure :: record_simple => mci_test_results_record_simple procedure :: record_extended => mci_test_results_record_extended <>= subroutine mci_test_results_record_simple (object, n_it, n_calls, & integral, error, efficiency, chain_weights, suppress) class(mci_test_results_t), intent(inout) :: object integer, intent(in) :: n_it integer, intent(in) :: n_calls real(default), intent(in) :: integral real(default), intent(in) :: error real(default), intent(in) :: efficiency real(default), dimension(:), intent(in), optional :: chain_weights logical, intent(in), optional :: suppress object%n_it = n_it object%n_calls = n_calls object%integral = integral object%error = error object%efficiency = efficiency end subroutine mci_test_results_record_simple subroutine mci_test_results_record_extended (object, n_it, n_calls, & & n_calls_valid, integral, error, efficiency, efficiency_pos, & & efficiency_neg, chain_weights, suppress) class(mci_test_results_t), intent(inout) :: object integer, intent(in) :: n_it integer, intent(in) :: n_calls integer, intent(in) :: n_calls_valid real(default), intent(in) :: integral real(default), intent(in) :: error real(default), intent(in) :: efficiency real(default), intent(in) :: efficiency_pos real(default), intent(in) :: efficiency_neg real(default), dimension(:), intent(in), optional :: chain_weights logical, intent(in), optional :: suppress object%n_it = n_it object%n_calls = n_calls object%integral = integral object%error = error object%efficiency = efficiency end subroutine mci_test_results_record_extended @ %def mci_test_results_record @ \subsubsection{Integrator configuration data} Construct and display a test integrator configuration object. <>= call test (mci_base_1, "mci_base_1", & "integrator configuration", & u, results) <>= public :: mci_base_1 <>= subroutine mci_base_1 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler real(default) :: integrand write (u, "(A)") "* Test output: mci_base_1" write (u, "(A)") "* Purpose: initialize and display & &test integrator" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (2, 2) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_t :: sampler) select type (sampler) type is (test_sampler_t) call sampler%init (2) end select write (u, "(A)") "* Evaluate sampler for given point and channel" write (u, "(A)") call sampler%evaluate (1, [0.25_default, 0.8_default], & integrand, mci_instance%x, mci_instance%f) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Compute MCI weight" write (u, "(A)") call mci_instance%compute_weight (1) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Get integrand and compute weight for another point" write (u, "(A)") call mci_instance%evaluate (sampler, 2, [0.5_default, 0.6_default]) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Recall results, again" write (u, "(A)") call mci_instance%final () deallocate (mci_instance) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) call mci_instance%fetch (sampler, 2) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Retrieve value" write (u, "(A)") write (u, "(1x,A,ES13.7)") "Weighted integrand = ", & mci_instance%get_value () call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_1" end subroutine mci_base_1 @ %def mci_base_1 @ \subsubsection{Trivial integral} Use the MCI approach to compute a trivial one-dimensional integral. <>= call test (mci_base_2, "mci_base_2", & "integration", & u, results) <>= public :: mci_base_2 <>= subroutine mci_base_2 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler write (u, "(A)") "* Test output: mci_base_2" write (u, "(A)") "* Purpose: perform a test integral" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (1, 1) select type (mci) type is (mci_test_t) call mci%set_divisions (10) end select call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_t :: sampler) select type (sampler) type is (test_sampler_t) call sampler%init (1) end select write (u, "(A)") "* Integrate" write (u, "(A)") call mci%integrate (mci_instance, sampler, 0, 0) call mci%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_2" end subroutine mci_base_2 @ %def mci_base_2 @ \subsubsection{Nontrivial integral} Use the MCI approach to compute a simple two-dimensional integral with two channels. <>= call test (mci_base_3, "mci_base_3", & "integration (two channels)", & u, results) <>= public :: mci_base_3 <>= subroutine mci_base_3 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler write (u, "(A)") "* Test output: mci_base_3" write (u, "(A)") "* Purpose: perform a nontrivial test integral" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_test_t) call mci%set_divisions (10) end select write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_t :: sampler) select type (sampler) type is (test_sampler_t) call sampler%init (2) end select write (u, "(A)") "* Integrate" write (u, "(A)") call mci%integrate (mci_instance, sampler, 0, 0) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with higher resolution" write (u, "(A)") select type (mci) type is (mci_test_t) call mci%set_divisions (100) end select call mci%integrate (mci_instance, sampler, 0, 0) call mci%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_3" end subroutine mci_base_3 @ %def mci_base_3 @ \subsubsection{Event generation} We generate ``random'' events, one weighted and one unweighted. The test implementation does not require an integration pass, we can generate events immediately. <>= call test (mci_base_4, "mci_base_4", & "event generation (two channels)", & u, results) <>= public :: mci_base_4 <>= subroutine mci_base_4 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_base_4" write (u, "(A)") "* Purpose: generate events" write (u, "(A)") write (u, "(A)") "* Initialize integrator, instance, sampler" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_test_t) call mci%set_divisions (10) end select call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_t :: sampler) select type (sampler) type is (test_sampler_t) call sampler%init (2) end select allocate (rng_test_t :: rng) call mci%import_rng (rng) write (u, "(A)") "* Generate weighted event" write (u, "(A)") call mci%generate_weighted_event (mci_instance, sampler) call sampler%write (u) write (u, *) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Generate unweighted event" write (u, "(A)") call mci%generate_unweighted_event (mci_instance, sampler) select type (mci) type is (mci_test_t) write (u, "(A,I0)") " Success in try ", mci%tries write (u, "(A)") end select call sampler%write (u) write (u, *) call mci_instance%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_4" end subroutine mci_base_4 @ %def mci_base_4 @ \subsubsection{Store and recall data} We generate an event and store the relevant data, i.e., the input parameters and the result value for a particular channel. Then we use those data to recover the event, as far as the MCI record is concerned. <>= call test (mci_base_5, "mci_base_5", & "store and recall", & u, results) <>= public :: mci_base_5 <>= subroutine mci_base_5 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng class(mci_state_t), allocatable :: state write (u, "(A)") "* Test output: mci_base_5" write (u, "(A)") "* Purpose: store and recall an event" write (u, "(A)") write (u, "(A)") "* Initialize integrator, instance, sampler" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_test_t) call mci%set_divisions (10) end select call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_t :: sampler) select type (sampler) type is (test_sampler_t) call sampler%init (2) end select allocate (rng_test_t :: rng) call mci%import_rng (rng) write (u, "(A)") "* Generate weighted event" write (u, "(A)") call mci%generate_weighted_event (mci_instance, sampler) call sampler%write (u) write (u, *) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Store data" write (u, "(A)") allocate (state) call mci_instance%store (state) call mci_instance%final () deallocate (mci_instance) call state%write (u) write (u, "(A)") write (u, "(A)") "* Recall data and rebuild event" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) call mci%rebuild_event (mci_instance, sampler, state) call sampler%write (u) write (u, *) call mci_instance%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_5" end subroutine mci_base_5 @ %def mci_base_5 @ \subsubsection{Chained channels} Chain channels together. In the base configuration, this just fills entries in an extra array (each channel may belong to a chain). In type implementations, this will be used for grouping equivalent channels by keeping their weights equal. <>= call test (mci_base_6, "mci_base_6", & "chained channels", & u, results) <>= public :: mci_base_6 <>= subroutine mci_base_6 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci write (u, "(A)") "* Test output: mci_base_6" write (u, "(A)") "* Purpose: initialize and display & &test integrator with chains" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (1, 5) write (u, "(A)") "* Introduce chains" write (u, "(A)") call mci%declare_chains ([1, 2, 2, 1, 2]) call mci%write (u) call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_6" end subroutine mci_base_6 @ %def mci_base_6 @ \subsubsection{Recording results} Compute a simple two-dimensional integral and record the result. <>= call test (mci_base_7, "mci_base_7", & "recording results", & u, results) <>= public :: mci_base_7 <>= subroutine mci_base_7 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(mci_results_t), allocatable :: results write (u, "(A)") "* Test output: mci_base_7" write (u, "(A)") "* Purpose: perform a nontrivial test integral & &and record results" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_test_t) call mci%set_divisions (10) end select write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_t :: sampler) select type (sampler) type is (test_sampler_t) call sampler%init (2) end select allocate (mci_test_results_t :: results) write (u, "(A)") "* Integrate" write (u, "(A)") call mci%integrate (mci_instance, sampler, 1, 1000, results) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Display results" write (u, "(A)") call results%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_7" end subroutine mci_base_7 @ %def mci_base_7 @ \subsubsection{Timer} Simple checks for the embedded timer. <>= call test (mci_base_8, "mci_base_8", & "timer", & u, results) <>= public :: mci_base_8 <>= subroutine mci_base_8 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci real(default) :: dummy write (u, "(A)") "* Test output: mci_base_8" write (u, "(A)") "* Purpose: check timer availability" write (u, "(A)") write (u, "(A)") "* Initialize integrator with timer" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_test_t) call mci%set_divisions (10) end select call mci%set_timer (active = .true.) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Start timer" write (u, "(A)") call mci%start_timer () call mci%write (u) write (u, "(A)") write (u, "(A)") "* Stop timer" write (u, "(A)") call mci%stop_timer () write (u, "(A)") " (ok)" write (u, "(A)") write (u, "(A)") "* Readout" write (u, "(A)") dummy = mci%get_time () write (u, "(A)") " (ok)" write (u, "(A)") write (u, "(A)") "* Deactivate timer" write (u, "(A)") call mci%set_timer (active = .false.) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_8" end subroutine mci_base_8 @ %def mci_base_8 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Iterations} This module defines a container for the list of iterations and calls, to be submitted to integration. <<[[iterations.f90]]>>= <> module iterations <> <> <> <> <> interface <> end interface end module iterations @ %def iterations @ <<[[iterations_sub.f90]]>>= <> submodule (iterations) iterations_s use io_units use diagnostics implicit none contains <> end submodule iterations_s @ %def iterations_s @ \subsection{The iterations list} Each integration pass has a number of iterations and a number of calls per iteration. The last pass produces the end result; the previous passes are used for adaptation. The flags [[adapt_grid]] and [[adapt_weight]] are used only if [[custom_adaptation]] is set. Otherwise, default settings are used that depend on the integration pass. <>= type :: iterations_spec_t private integer :: n_it = 0 integer :: n_calls = 0 logical :: custom_adaptation = .false. logical :: adapt_grids = .false. logical :: adapt_weights = .false. end type iterations_spec_t @ %def iterations_spec_t @ We build up a list of iterations. <>= public :: iterations_list_t <>= type :: iterations_list_t private integer :: n_pass = 0 type(iterations_spec_t), dimension(:), allocatable :: pass contains <> end type iterations_list_t @ %def iterations_list_t @ Initialize an iterations list. For each pass, we have to specify the number of iterations and calls. We may provide the adaption conventions explicitly, either as character codes or as logicals. For passes where the adaptation conventions are not specified, we use the following default setting: adapt weights and grids for all passes except the last one. <>= procedure :: init => iterations_list_init <>= module subroutine iterations_list_init & (it_list, n_it, n_calls, adapt, adapt_code, adapt_grids, adapt_weights) class(iterations_list_t), intent(inout) :: it_list integer, dimension(:), intent(in) :: n_it, n_calls logical, dimension(:), intent(in), optional :: adapt type(string_t), dimension(:), intent(in), optional :: adapt_code logical, dimension(:), intent(in), optional :: adapt_grids, adapt_weights end subroutine iterations_list_init <>= module subroutine iterations_list_init & (it_list, n_it, n_calls, adapt, adapt_code, adapt_grids, adapt_weights) class(iterations_list_t), intent(inout) :: it_list integer, dimension(:), intent(in) :: n_it, n_calls logical, dimension(:), intent(in), optional :: adapt type(string_t), dimension(:), intent(in), optional :: adapt_code logical, dimension(:), intent(in), optional :: adapt_grids, adapt_weights integer :: i it_list%n_pass = size (n_it) if (allocated (it_list%pass)) deallocate (it_list%pass) allocate (it_list%pass (it_list%n_pass)) it_list%pass%n_it = n_it it_list%pass%n_calls = n_calls if (present (adapt)) then it_list%pass%custom_adaptation = adapt do i = 1, it_list%n_pass if (adapt(i)) then if (verify (adapt_code(i), "wg") /= 0) then call msg_error ("iteration specification: " & // "adaptation code letters must be 'w' or 'g'") end if it_list%pass(i)%adapt_grids = scan (adapt_code(i), "g") /= 0 it_list%pass(i)%adapt_weights = scan (adapt_code(i), "w") /= 0 end if end do else if (present (adapt_grids) .and. present (adapt_weights)) then it_list%pass%custom_adaptation = .true. it_list%pass%adapt_grids = adapt_grids it_list%pass%adapt_weights = adapt_weights end if do i = 1, it_list%n_pass - 1 if (.not. it_list%pass(i)%custom_adaptation) then it_list%pass(i)%adapt_grids = .true. it_list%pass(i)%adapt_weights = .true. end if end do end subroutine iterations_list_init @ %def iterations_list_init <>= procedure :: clear => iterations_list_clear <>= module subroutine iterations_list_clear (it_list) class(iterations_list_t), intent(inout) :: it_list end subroutine iterations_list_clear <>= module subroutine iterations_list_clear (it_list) class(iterations_list_t), intent(inout) :: it_list it_list%n_pass = 0 deallocate (it_list%pass) end subroutine iterations_list_clear @ %def iterations_list_clear @ Write the list of iterations. <>= procedure :: write => iterations_list_write <>= module subroutine iterations_list_write (it_list, unit) class(iterations_list_t), intent(in) :: it_list integer, intent(in), optional :: unit end subroutine iterations_list_write <>= module subroutine iterations_list_write (it_list, unit) class(iterations_list_t), intent(in) :: it_list integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(A)") char (it_list%to_string ()) end subroutine iterations_list_write @ %def iterations_list_write @ The output as a single-line string. <>= procedure :: to_string => iterations_list_to_string <>= module function iterations_list_to_string (it_list) result (buffer) class(iterations_list_t), intent(in) :: it_list type(string_t) :: buffer end function iterations_list_to_string <>= module function iterations_list_to_string (it_list) result (buffer) class(iterations_list_t), intent(in) :: it_list type(string_t) :: buffer character(30) :: ibuf integer :: i buffer = "iterations = " if (it_list%n_pass > 0) then do i = 1, it_list%n_pass if (i > 1) buffer = buffer // ", " write (ibuf, "(I0,':',I0)") & it_list%pass(i)%n_it, it_list%pass(i)%n_calls buffer = buffer // trim (ibuf) if (it_list%pass(i)%custom_adaptation & .or. it_list%pass(i)%adapt_grids & .or. it_list%pass(i)%adapt_weights) then buffer = buffer // ':"' if (it_list%pass(i)%adapt_grids) buffer = buffer // "g" if (it_list%pass(i)%adapt_weights) buffer = buffer // "w" buffer = buffer // '"' end if end do else buffer = buffer // "[undefined]" end if end function iterations_list_to_string @ %def iterations_list_to_string @ \subsection{Tools} Return the total number of passes. <>= procedure :: get_n_pass => iterations_list_get_n_pass <>= module function iterations_list_get_n_pass (it_list) result (n_pass) class(iterations_list_t), intent(in) :: it_list integer :: n_pass end function iterations_list_get_n_pass <>= module function iterations_list_get_n_pass (it_list) result (n_pass) class(iterations_list_t), intent(in) :: it_list integer :: n_pass n_pass = it_list%n_pass end function iterations_list_get_n_pass @ %def iterations_list_get_n_pass @ Return the number of calls for a specific pass. <>= procedure :: get_n_calls => iterations_list_get_n_calls <>= module function iterations_list_get_n_calls (it_list, pass) result (n_calls) class(iterations_list_t), intent(in) :: it_list integer :: n_calls integer, intent(in) :: pass end function iterations_list_get_n_calls <>= module function iterations_list_get_n_calls (it_list, pass) result (n_calls) class(iterations_list_t), intent(in) :: it_list integer :: n_calls integer, intent(in) :: pass if (pass <= it_list%n_pass) then n_calls = it_list%pass(pass)%n_calls else n_calls = 0 end if end function iterations_list_get_n_calls @ %def iterations_list_get_n_calls @ <>= procedure :: set_n_calls => iterations_list_set_n_calls <>= module subroutine iterations_list_set_n_calls (it_list, pass, n_calls) class(iterations_list_t), intent(inout) :: it_list integer, intent(in) :: pass, n_calls end subroutine iterations_list_set_n_calls <>= module subroutine iterations_list_set_n_calls (it_list, pass, n_calls) class(iterations_list_t), intent(inout) :: it_list integer, intent(in) :: pass, n_calls it_list%pass(pass)%n_calls = n_calls end subroutine iterations_list_set_n_calls @ %def iterations_list_set_n_calls @ Get the adaptation mode (automatic/custom) and, for custom adaptation, the flags for a specific pass. <>= procedure :: adapt_grids => iterations_list_adapt_grids procedure :: adapt_weights => iterations_list_adapt_weights <>= module function iterations_list_adapt_grids (it_list, pass) result (flag) logical :: flag class(iterations_list_t), intent(in) :: it_list integer, intent(in) :: pass end function iterations_list_adapt_grids module function iterations_list_adapt_weights (it_list, pass) result (flag) logical :: flag class(iterations_list_t), intent(in) :: it_list integer, intent(in) :: pass end function iterations_list_adapt_weights <>= module function iterations_list_adapt_grids (it_list, pass) result (flag) logical :: flag class(iterations_list_t), intent(in) :: it_list integer, intent(in) :: pass if (pass <= it_list%n_pass) then flag = it_list%pass(pass)%adapt_grids else flag = .false. end if end function iterations_list_adapt_grids module function iterations_list_adapt_weights (it_list, pass) result (flag) logical :: flag class(iterations_list_t), intent(in) :: it_list integer, intent(in) :: pass if (pass <= it_list%n_pass) then flag = it_list%pass(pass)%adapt_weights else flag = .false. end if end function iterations_list_adapt_weights @ %def iterations_list_has_custom_adaptation @ %def iterations_list_adapt_grids @ %def iterations_list_adapt_weights @ Return the total number of iterations / the iterations for a specific pass. <>= procedure :: get_n_it => iterations_list_get_n_it <>= module function iterations_list_get_n_it (it_list, pass) result (n_it) class(iterations_list_t), intent(in) :: it_list integer :: n_it integer, intent(in) :: pass end function iterations_list_get_n_it <>= module function iterations_list_get_n_it (it_list, pass) result (n_it) class(iterations_list_t), intent(in) :: it_list integer :: n_it integer, intent(in) :: pass if (pass <= it_list%n_pass) then n_it = it_list%pass(pass)%n_it else n_it = 0 end if end function iterations_list_get_n_it @ %def iterations_list_get_n_it @ \subsection{Iteration Multipliers} <>= public :: iteration_multipliers_t <>= type :: iteration_multipliers_t real(default) :: mult_real = 1._default real(default) :: mult_virt = 1._default real(default) :: mult_dglap = 1._default real(default) :: mult_threshold = 1._default integer, dimension(:), allocatable :: n_calls0 end type iteration_multipliers_t @ %def iterations_multipliers @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[iterations_ut.f90]]>>= <> module iterations_ut use unit_tests use iterations_uti <> <> contains <> end module iterations_ut @ %def iterations_ut @ <<[[iterations_uti.f90]]>>= <> module iterations_uti <> use iterations <> <> contains <> end module iterations_uti @ %def iterations_ut @ API: driver for the unit tests below. <>= public :: iterations_test <>= subroutine iterations_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine iterations_test @ %def iterations_test @ \subsubsection{Empty list} <>= call test (iterations_1, "iterations_1", & "empty iterations list", & u, results) <>= public :: iterations_1 <>= subroutine iterations_1 (u) integer, intent(in) :: u type(iterations_list_t) :: it_list write (u, "(A)") "* Test output: iterations_1" write (u, "(A)") "* Purpose: display empty iterations list" write (u, "(A)") call it_list%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: iterations_1" end subroutine iterations_1 @ %def iterations_1 @ \subsubsection{Fill list} <>= call test (iterations_2, "iterations_2", & "create iterations list", & u, results) <>= public :: iterations_2 <>= subroutine iterations_2 (u) integer, intent(in) :: u type(iterations_list_t) :: it_list write (u, "(A)") "* Test output: iterations_2" write (u, "(A)") "* Purpose: fill and display iterations list" write (u, "(A)") write (u, "(A)") "* Minimal setup (2 passes)" write (u, "(A)") call it_list%init ([2, 4], [5000, 20000]) call it_list%write (u) call it_list%clear () write (u, "(A)") write (u, "(A)") "* Setup with flags (3 passes)" write (u, "(A)") call it_list%init ([2, 4, 5], [5000, 20000, 400], & [.false., .true., .true.], & [var_str (""), var_str ("g"), var_str ("wg")]) call it_list%write (u) write (u, "(A)") write (u, "(A)") "* Extract data" write (u, "(A)") write (u, "(A,I0)") "n_pass = ", it_list%get_n_pass () write (u, "(A)") write (u, "(A,I0)") "n_calls(2) = ", it_list%get_n_calls (2) write (u, "(A)") write (u, "(A,I0)") "n_it(3) = ", it_list%get_n_it (3) write (u, "(A)") write (u, "(A)") "* Test output end: iterations_2" end subroutine iterations_2 @ %def iterations_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Integration results} We record integration results and errors in a dedicated type. This allows us to do further statistics such as weighted average, chi-squared, grouping by integration passes, etc. <<[[integration_results.f90]]>>= module integration_results <> <> use os_interface use mci_base <> <> <> <> <> interface <> end interface end module integration_results @ %def integration_results <<[[integration_results_sub.f90]]>>= <> submodule (integration_results) integration_results_s use io_units use format_utils, only: mp_format, pac_fmt use format_defs, only: FMT_10, FMT_14 use numeric_utils, only: pacify use diagnostics use md5 implicit none contains <> end submodule integration_results_s @ %def integration_results_s @ \subsection{Integration results entry} This object collects the results of an integration pass and makes them available to the outside. The results object has to distinguish the process type: We store the process type, the index of the integration pass and the absolute iteration index, the number of iterations contained in this result (for averages), and the integral (cross section or partial width), error estimate, efficiency. For intermediate results, we set a flag if this result is an improvement w.r.t. previous ones. The process type indicates decay or scattering. Dummy entries (skipped iterations) have a process type of [[PRC_UNKNOWN]]. The additional information [[n_calls_valid]], [[efficiency_pos]] and [[efficiency_neg]] are stored, but only used in verbose mode. <>= public :: integration_entry_t <>= type :: integration_entry_t private integer :: process_type = PRC_UNKNOWN integer :: pass = 0 integer :: it = 0 integer :: n_it = 0 integer :: n_calls = 0 integer :: n_calls_valid = 0 logical :: improved = .false. real(default) :: integral = 0 real(default) :: error = 0 real(default) :: efficiency = 0 real(default) :: efficiency_pos = 0 real(default) :: efficiency_neg = 0 real(default) :: chi2 = 0 real(default), dimension(:), allocatable :: chain_weights contains <> end type integration_entry_t @ %def integration_result_t @ The possible values of the type indicator: <>= integer, parameter, public :: PRC_UNKNOWN = 0 integer, parameter, public :: PRC_DECAY = 1 integer, parameter, public :: PRC_SCATTERING = 2 @ %def PRC_UNKNOWN PRC_DECAY PRC_SCATTERING @ Initialize with all relevant data. <>= interface integration_entry_t module procedure integration_entry_init end interface integration_entry_t <>= module function integration_entry_init (process_type, pass,& & it, n_it, n_calls, n_calls_valid, improved, integral, error,& & efficiency, efficiency_pos, efficiency_neg, chi2, chain_weights)& & result (entry) type(integration_entry_t) :: entry integer, intent(in) :: process_type, pass, it, n_it, & n_calls, n_calls_valid logical, intent(in) :: improved real(default), intent(in) :: integral, error, efficiency, & efficiency_pos, efficiency_neg real(default), intent(in), optional :: chi2 real(default), dimension(:), intent(in), optional :: chain_weights end function integration_entry_init <>= module function integration_entry_init (process_type, pass,& & it, n_it, n_calls, n_calls_valid, improved, integral, error,& & efficiency, efficiency_pos, efficiency_neg, chi2, chain_weights)& & result (entry) type(integration_entry_t) :: entry integer, intent(in) :: process_type, pass, it, n_it, n_calls, n_calls_valid logical, intent(in) :: improved real(default), intent(in) :: integral, error, efficiency, & efficiency_pos, efficiency_neg real(default), intent(in), optional :: chi2 real(default), dimension(:), intent(in), optional :: chain_weights entry%process_type = process_type entry%pass = pass entry%it = it entry%n_it = n_it entry%n_calls = n_calls entry%n_calls_valid = n_calls_valid entry%improved = improved entry%integral = integral entry%error = error entry%efficiency = efficiency entry%efficiency_pos = efficiency_pos entry%efficiency_neg = efficiency_neg if (present (chi2)) entry%chi2 = chi2 if (present (chain_weights)) then allocate (entry%chain_weights (size (chain_weights))) entry%chain_weights = chain_weights end if end function integration_entry_init @ %def integration_entry_init @ Access values, some of them computed on demand: <>= procedure :: get_pass => integration_entry_get_pass procedure :: get_n_calls => integration_entry_get_n_calls procedure :: get_n_calls_valid => integration_entry_get_n_calls_valid procedure :: get_integral => integration_entry_get_integral procedure :: get_error => integration_entry_get_error procedure :: get_rel_error => integration_entry_get_relative_error procedure :: get_accuracy => integration_entry_get_accuracy procedure :: get_efficiency => integration_entry_get_efficiency procedure :: get_efficiency_pos => integration_entry_get_efficiency_pos procedure :: get_efficiency_neg => integration_entry_get_efficiency_neg procedure :: get_chi2 => integration_entry_get_chi2 procedure :: has_improved => integration_entry_has_improved procedure :: get_n_groves => integration_entry_get_n_groves <>= elemental module function integration_entry_get_pass (entry) result (n) integer :: n class(integration_entry_t), intent(in) :: entry end function integration_entry_get_pass elemental module function integration_entry_get_n_calls (entry) result (n) integer :: n class(integration_entry_t), intent(in) :: entry end function integration_entry_get_n_calls elemental module function integration_entry_get_n_calls_valid & (entry) result (n) integer :: n class(integration_entry_t), intent(in) :: entry end function integration_entry_get_n_calls_valid elemental module function integration_entry_get_integral (entry) result (int) real(default) :: int class(integration_entry_t), intent(in) :: entry end function integration_entry_get_integral elemental module function integration_entry_get_error (entry) result (err) real(default) :: err class(integration_entry_t), intent(in) :: entry end function integration_entry_get_error elemental module function integration_entry_get_relative_error & (entry) result (err) real(default) :: err class(integration_entry_t), intent(in) :: entry end function integration_entry_get_relative_error elemental module function integration_entry_get_accuracy & (entry) result (acc) real(default) :: acc class(integration_entry_t), intent(in) :: entry end function integration_entry_get_accuracy elemental module function accuracy (integral, error, n_calls) result (acc) real(default) :: acc real(default), intent(in) :: integral, error integer, intent(in) :: n_calls end function accuracy elemental module function integration_entry_get_efficiency & (entry) result (eff) real(default) :: eff class(integration_entry_t), intent(in) :: entry end function integration_entry_get_efficiency elemental module function integration_entry_get_efficiency_pos & (entry) result (eff) real(default) :: eff class(integration_entry_t), intent(in) :: entry end function integration_entry_get_efficiency_pos elemental module function integration_entry_get_efficiency_neg & (entry) result (eff) real(default) :: eff class(integration_entry_t), intent(in) :: entry end function integration_entry_get_efficiency_neg elemental module function integration_entry_get_chi2 (entry) result (chi2) real(default) :: chi2 class(integration_entry_t), intent(in) :: entry end function integration_entry_get_chi2 elemental module function integration_entry_has_improved & (entry) result (flag) logical :: flag class(integration_entry_t), intent(in) :: entry end function integration_entry_has_improved elemental module function integration_entry_get_n_groves & (entry) result (n_groves) integer :: n_groves class(integration_entry_t), intent(in) :: entry end function integration_entry_get_n_groves <>= elemental module function integration_entry_get_pass (entry) result (n) integer :: n class(integration_entry_t), intent(in) :: entry n = entry%pass end function integration_entry_get_pass elemental module function integration_entry_get_n_calls (entry) result (n) integer :: n class(integration_entry_t), intent(in) :: entry n = entry%n_calls end function integration_entry_get_n_calls elemental module function integration_entry_get_n_calls_valid & (entry) result (n) integer :: n class(integration_entry_t), intent(in) :: entry n = entry%n_calls_valid end function integration_entry_get_n_calls_valid elemental module function integration_entry_get_integral (entry) result (int) real(default) :: int class(integration_entry_t), intent(in) :: entry int = entry%integral end function integration_entry_get_integral elemental module function integration_entry_get_error (entry) result (err) real(default) :: err class(integration_entry_t), intent(in) :: entry err = entry%error end function integration_entry_get_error elemental module function integration_entry_get_relative_error & (entry) result (err) real(default) :: err class(integration_entry_t), intent(in) :: entry err = 0 if (entry%integral /= 0) then err = entry%error / entry%integral end if end function integration_entry_get_relative_error elemental module function integration_entry_get_accuracy & (entry) result (acc) real(default) :: acc class(integration_entry_t), intent(in) :: entry acc = accuracy (entry%integral, entry%error, entry%n_calls) end function integration_entry_get_accuracy elemental module function accuracy (integral, error, n_calls) result (acc) real(default) :: acc real(default), intent(in) :: integral, error integer, intent(in) :: n_calls acc = 0 if (integral /= 0) then acc = error / integral * sqrt (real (n_calls, default)) end if end function accuracy elemental module function integration_entry_get_efficiency & (entry) result (eff) real(default) :: eff class(integration_entry_t), intent(in) :: entry eff = entry%efficiency end function integration_entry_get_efficiency elemental module function integration_entry_get_efficiency_pos & (entry) result (eff) real(default) :: eff class(integration_entry_t), intent(in) :: entry eff = entry%efficiency_pos end function integration_entry_get_efficiency_pos elemental module function integration_entry_get_efficiency_neg & (entry) result (eff) real(default) :: eff class(integration_entry_t), intent(in) :: entry eff = entry%efficiency_neg end function integration_entry_get_efficiency_neg elemental module function integration_entry_get_chi2 (entry) result (chi2) real(default) :: chi2 class(integration_entry_t), intent(in) :: entry chi2 = entry%chi2 end function integration_entry_get_chi2 elemental module function integration_entry_has_improved & (entry) result (flag) logical :: flag class(integration_entry_t), intent(in) :: entry flag = entry%improved end function integration_entry_has_improved elemental module function integration_entry_get_n_groves & (entry) result (n_groves) integer :: n_groves class(integration_entry_t), intent(in) :: entry n_groves = 0 if (allocated (entry%chain_weights)) then n_groves = size (entry%chain_weights, 1) end if end function integration_entry_get_n_groves @ %def integration_entry_get_pass @ %def integration_entry_get_integral @ %def integration_entry_get_error @ %def integration_entry_get_relative_error @ %def integration_entry_get_accuracy @ %def accuracy @ %def integration_entry_get_efficiency @ %def integration_entry_get_chi2 @ %def integration_entry_has_improved @ %def integration_entry_get_n_groves @ This writes the standard result account into one screen line. The verbose version uses multiple lines and prints the unabridged values. Dummy entries are not written. <>= procedure :: write => integration_entry_write procedure :: write_verbose => integration_entry_write_verbose <>= module subroutine integration_entry_write (entry, unit, verbosity, suppress) class(integration_entry_t), intent(in) :: entry integer, intent(in), optional :: unit integer, intent(in), optional :: verbosity logical, intent(in), optional :: suppress end subroutine integration_entry_write module subroutine integration_entry_write_verbose (entry, unit) class(integration_entry_t), intent(in) :: entry integer, intent(in) :: unit end subroutine integration_entry_write_verbose <>= module subroutine integration_entry_write (entry, unit, verbosity, suppress) class(integration_entry_t), intent(in) :: entry integer, intent(in), optional :: unit integer, intent(in), optional :: verbosity logical, intent(in), optional :: suppress integer :: u character(1) :: star character(12) :: fmt character(7) :: fmt2 character(120) :: buffer integer :: verb logical :: supp u = given_output_unit (unit); if (u < 0) return verb = 0; if (present (verbosity)) verb = verbosity supp = .false.; if (present (suppress)) supp = suppress if (entry%process_type /= PRC_UNKNOWN) then if (entry%improved .and. .not. supp) then star = "*" else star = " " end if call pac_fmt (fmt, FMT_14, "3x," // FMT_10 // ",1x", suppress) call pac_fmt (fmt2, "1x,F6.2", "2x,F5.1", suppress) write (buffer, "(1x,I3,1x,I10)") entry%it, entry%n_calls if (verb > 1) then write (buffer, "(A,1x,I10)") trim (buffer), entry%n_calls_valid end if write (buffer, "(A,1x," // fmt // ",1x,ES9.2,1x,F7.2," // & "1x,F7.2,A1," // fmt2 // ")") & trim (buffer), & entry%integral, & abs(entry%error), & abs(integration_entry_get_relative_error (entry)) * 100, & abs(integration_entry_get_accuracy (entry)), & star, & entry%efficiency * 100 if (verb > 2) then write (buffer, "(A,1X," // fmt2 // ",1X," // fmt2 // ")") & trim (buffer), & entry%efficiency_pos * 100, & entry%efficiency_neg * 100 end if if (entry%n_it /= 1) then write (buffer, "(A,1x,F7.2,1x,I3)") & trim (buffer), & entry%chi2, & entry%n_it end if write (u, "(A)") trim (buffer) end if flush (u) end subroutine integration_entry_write module subroutine integration_entry_write_verbose (entry, unit) class(integration_entry_t), intent(in) :: entry integer, intent(in) :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, *) " process_type = ", entry%process_type write (u, *) " pass = ", entry%pass write (u, *) " it = ", entry%it write (u, *) " n_it = ", entry%n_it write (u, *) " n_calls = ", entry%n_calls write (u, *) " n_calls_valid = ", entry%n_calls_valid write (u, *) " improved = ", entry%improved write (u, *) " integral = ", entry%integral write (u, *) " error = ", entry%error write (u, *) " efficiency = ", entry%efficiency write (u, *) "efficiency_pos = ", entry%efficiency_pos write (u, *) "efficiency_neg = ", entry%efficiency_neg write (u, *) " chi2 = ", entry%chi2 if (allocated (entry%chain_weights)) then write (u, *) " n_groves = ", size (entry%chain_weights) write (u, *) "chain_weights = ", entry%chain_weights else write (u, *) " n_groves = 0" end if flush (u) end subroutine integration_entry_write_verbose @ %def integration_entry_write @ Read the entry, assuming it has been written in verbose format. <>= procedure :: read => integration_entry_read <>= module subroutine integration_entry_read (entry, unit) class(integration_entry_t), intent(out) :: entry integer, intent(in) :: unit end subroutine integration_entry_read <>= module subroutine integration_entry_read (entry, unit) class(integration_entry_t), intent(out) :: entry integer, intent(in) :: unit character(30) :: dummy character :: equals integer :: n_groves read (unit, *) dummy, equals, entry%process_type read (unit, *) dummy, equals, entry%pass read (unit, *) dummy, equals, entry%it read (unit, *) dummy, equals, entry%n_it read (unit, *) dummy, equals, entry%n_calls read (unit, *) dummy, equals, entry%n_calls_valid read (unit, *) dummy, equals, entry%improved read (unit, *) dummy, equals, entry%integral read (unit, *) dummy, equals, entry%error read (unit, *) dummy, equals, entry%efficiency read (unit, *) dummy, equals, entry%efficiency_pos read (unit, *) dummy, equals, entry%efficiency_neg read (unit, *) dummy, equals, entry%chi2 read (unit, *) dummy, equals, n_groves if (n_groves /= 0) then allocate (entry%chain_weights (n_groves)) read (unit, *) dummy, equals, entry%chain_weights end if end subroutine integration_entry_read @ %def integration_entry_read @ Write an account of the channel weights, accumulated by groves. <>= procedure :: write_chain_weights => integration_entry_write_chain_weights <>= module subroutine integration_entry_write_chain_weights (entry, unit) class(integration_entry_t), intent(in) :: entry integer, intent(in), optional :: unit end subroutine integration_entry_write_chain_weights <>= module subroutine integration_entry_write_chain_weights (entry, unit) class(integration_entry_t), intent(in) :: entry integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return if (allocated (entry%chain_weights)) then do i = 1, size (entry%chain_weights) write (u, "(1x,I3)", advance="no") & nint (entry%chain_weights(i) * 100) end do write (u, *) end if end subroutine integration_entry_write_chain_weights @ %def integration_entry_write_chain_weights @ \subsection{Combined integration results} We collect a list of results which grows during the execution of the program. This is implemented as an array which grows if necessary; so we can easily compute averages. We implement this as an extension of the [[mci_results_t]] which is defined in [[mci_base]] as an abstract type. We thus decouple the implementation of the integrator from the implementation of the results display, but nevertheless can record intermediate results during integration. This implies that the present extension implements a [[record]] method. <>= public :: integration_results_t <>= type, extends (mci_results_t) :: integration_results_t private integer :: process_type = PRC_UNKNOWN integer :: current_pass = 0 integer :: n_pass = 0 integer :: n_it = 0 logical :: screen = .false. integer :: unit = 0 integer :: verbosity = 0 real(default) :: error_threshold = 0 type(integration_entry_t), dimension(:), allocatable :: entry type(integration_entry_t), dimension(:), allocatable :: average contains <> end type integration_results_t @ %def integration_results_t @ The array is extended in chunks of 10 entries. <>= integer, parameter :: RESULTS_CHUNK_SIZE = 10 @ %def RESULTS_CHUNK_SIZE @ <>= procedure :: init => integration_results_init <>= module subroutine integration_results_init (results, process_type) class(integration_results_t), intent(out) :: results integer, intent(in) :: process_type end subroutine integration_results_init <>= module subroutine integration_results_init (results, process_type) class(integration_results_t), intent(out) :: results integer, intent(in) :: process_type results%process_type = process_type results%n_pass = 0 results%n_it = 0 allocate (results%entry (RESULTS_CHUNK_SIZE)) allocate (results%average (RESULTS_CHUNK_SIZE)) end subroutine integration_results_init @ %def integration_results_init @ Set verbose output of the integration results. In verbose mode, valid calls, negative as positive efficiency will be printed. <>= procedure :: set_verbosity => integration_results_set_verbosity <>= module subroutine integration_results_set_verbosity (results, verbosity) class(integration_results_t), intent(inout) :: results integer, intent(in) :: verbosity end subroutine integration_results_set_verbosity <>= module subroutine integration_results_set_verbosity (results, verbosity) class(integration_results_t), intent(inout) :: results integer, intent(in) :: verbosity results%verbosity = verbosity end subroutine integration_results_set_verbosity @ %def integration_results_set_verbose @ Set additional parameters: the [[error_threshold]] declares that any error value (in absolute numbers) smaller than this is to be considered zero. <>= procedure :: set_error_threshold => integration_results_set_error_threshold <>= module subroutine integration_results_set_error_threshold & (results, error_threshold) class(integration_results_t), intent(inout) :: results real(default), intent(in) :: error_threshold end subroutine integration_results_set_error_threshold <>= module subroutine integration_results_set_error_threshold & (results, error_threshold) class(integration_results_t), intent(inout) :: results real(default), intent(in) :: error_threshold results%error_threshold = error_threshold end subroutine integration_results_set_error_threshold @ %def integration_results_set_error_threshold @ Output (ASCII format). The [[verbose]] format is used for writing the header in grid files. <>= procedure :: write => integration_results_write procedure :: write_verbose => integration_results_write_verbose <>= module subroutine integration_results_write (object, unit, suppress) class(integration_results_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: suppress end subroutine integration_results_write module subroutine integration_results_write_verbose (object, unit) class(integration_results_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine integration_results_write_verbose <>= module subroutine integration_results_write (object, unit, suppress) class(integration_results_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: suppress logical :: verb integer :: u, n u = given_output_unit (unit); if (u < 0) return call object%write_dline (unit) if (object%n_it /= 0) then call object%write_header (unit, logfile = .false.) call object%write_dline (unit) do n = 1, object%n_it if (n > 1) then if (object%entry(n)%pass /= object%entry(n-1)%pass) then call object%write_hline (unit) call object%average(object%entry(n-1)%pass)%write ( & & unit, suppress = suppress) call object%write_hline (unit) end if end if call object%entry(n)%write (unit, & suppress = suppress) end do call object%write_hline(unit) call object%average(object%n_pass)%write (unit, suppress = suppress) else call msg_message ("[WHIZARD integration results: empty]", unit) end if call object%write_dline (unit) flush (u) end subroutine integration_results_write module subroutine integration_results_write_verbose (object, unit) class(integration_results_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, n u = given_output_unit (unit); if (u < 0) return write (u, *) "begin(integration_results)" write (u, *) " n_pass = ", object%n_pass write (u, *) " n_it = ", object%n_it if (object%n_it > 0) then write (u, *) "begin(integration_pass)" do n = 1, object%n_it if (n > 1) then if (object%entry(n)%pass /= object%entry(n-1)%pass) then write (u, *) "end(integration_pass)" write (u, *) "begin(integration_pass)" end if end if write (u, *) "begin(iteration)" call object%entry(n)%write_verbose (unit) write (u, *) "end(iteration)" end do write (u, *) "end(integration_pass)" end if write (u, *) "end(integration_results)" flush (u) end subroutine integration_results_write_verbose @ %def integration_results_write integration_results_verbose @ Write a concise table of chain weights, i.e., the channel history where channels are collected by chains. <>= procedure :: write_chain_weights => & integration_results_write_chain_weights <>= module subroutine integration_results_write_chain_weights (results, unit) class(integration_results_t), intent(in) :: results integer, intent(in), optional :: unit end subroutine integration_results_write_chain_weights <>= module subroutine integration_results_write_chain_weights (results, unit) class(integration_results_t), intent(in) :: results integer, intent(in), optional :: unit integer :: u, i, n u = given_output_unit (unit); if (u < 0) return if (allocated (results%entry(1)%chain_weights) .and. results%n_it /= 0) then call msg_message ("Phase-space chain (grove) weight history: " & // "(numbers in %)", unit) write (u, "(A9)", advance="no") "| chain |" do i = 1, integration_entry_get_n_groves (results%entry(1)) write (u, "(1x,I3)", advance="no") i end do write (u, *) call results%write_dline (unit) do n = 1, results%n_it if (n > 1) then if (results%entry(n)%pass /= results%entry(n-1)%pass) then call results%write_hline (unit) end if end if write (u, "(1x,I6,1x,A1)", advance="no") n, "|" call results%entry(n)%write_chain_weights (unit) end do flush (u) call results%write_dline(unit) end if end subroutine integration_results_write_chain_weights @ %def integration_results_write_chain_weights @ Read the list from file. The file must be written using the [[verbose]] option of the writing routine. <>= procedure :: read => integration_results_read <>= module subroutine integration_results_read (results, unit) class(integration_results_t), intent(out) :: results integer, intent(in) :: unit end subroutine integration_results_read <>= module subroutine integration_results_read (results, unit) class(integration_results_t), intent(out) :: results integer, intent(in) :: unit character(80) :: buffer character :: equals integer :: pass, it read (unit, *) buffer if (trim (adjustl (buffer)) /= "begin(integration_results)") then call read_err (); return end if read (unit, *) buffer, equals, results%n_pass read (unit, *) buffer, equals, results%n_it allocate (results%entry (results%n_it + RESULTS_CHUNK_SIZE)) allocate (results%average (results%n_it + RESULTS_CHUNK_SIZE)) it = 0 do pass = 1, results%n_pass read (unit, *) buffer if (trim (adjustl (buffer)) /= "begin(integration_pass)") then call read_err (); return end if READ_ENTRIES: do read (unit, *) buffer if (trim (adjustl (buffer)) /= "begin(iteration)") then exit READ_ENTRIES end if it = it + 1 call results%entry(it)%read (unit) read (unit, *) buffer if (trim (adjustl (buffer)) /= "end(iteration)") then call read_err (); return end if end do READ_ENTRIES if (trim (adjustl (buffer)) /= "end(integration_pass)") then call read_err (); return end if results%average(pass) = compute_average (results%entry, pass) end do read (unit, *) buffer if (trim (adjustl (buffer)) /= "end(integration_results)") then call read_err (); return end if contains subroutine read_err () call msg_fatal ("Reading integration results from file: syntax error") end subroutine read_err end subroutine integration_results_read @ %def integration_results_read @ Auxiliary output. <>= procedure, private :: write_header procedure, private :: write_hline procedure, private :: write_dline <>= module subroutine write_header (results, unit, logfile) class(integration_results_t), intent(in) :: results integer, intent(in), optional :: unit logical, intent(in), optional :: logfile end subroutine write_header module subroutine write_hline (results, unit) class(integration_results_t), intent(in) :: results integer, intent(in), optional :: unit end subroutine write_hline module subroutine write_dline (results, unit) class(integration_results_t), intent(in) :: results integer, intent(in), optional :: unit end subroutine write_dline <>= module subroutine write_header (results, unit, logfile) class(integration_results_t), intent(in) :: results integer, intent(in), optional :: unit logical, intent(in), optional :: logfile character(5) :: phys_unit integer :: u u = given_output_unit (unit); if (u < 0) return select case (results%process_type) case (PRC_DECAY); phys_unit = "[GeV]" case (PRC_SCATTERING); phys_unit = "[fb] " case default phys_unit = " " end select write (msg_buffer, "(A, A)") & "It Calls" if (results%verbosity > 1) then write (msg_buffer, "(A, A)") trim (msg_buffer), & " Valid" end if write (msg_buffer, "(A, A)") trim (msg_buffer), & " Integral" // phys_unit // & " Error" // phys_unit // & " Err[%] Acc Eff[%]" if (results%verbosity > 2) then write (msg_buffer, "(A, A)") trim (msg_buffer), & " (+)[%] (-)[%]" end if write (msg_buffer, "(A, A)") trim (msg_buffer), & " Chi2 N[It] |" call msg_message (unit=u, logfile=logfile) end subroutine write_header module subroutine write_hline (results, unit) class(integration_results_t), intent(in) :: results integer, intent(in), optional :: unit integer :: u, len u = given_output_unit (unit); if (u < 0) return len = 77 if (results%verbosity > 1) len = len + 11 if (results%verbosity > 2) len = len + 16 write (u, "(A)") "|" // (repeat ("-", len)) // "|" flush (u) end subroutine write_hline module subroutine write_dline (results, unit) class(integration_results_t), intent(in) :: results integer, intent(in), optional :: unit integer :: u, len u = given_output_unit (unit); if (u < 0) return len = 77 if (results%verbosity > 1) len = len + 11 if (results%verbosity > 2) len = len + 16 write (u, "(A)") "|" // (repeat ("=", len)) // "|" flush (u) end subroutine write_dline @ %def write_header write_hline write_dline @ During integration, we do not want to print all results at once, but each intermediate result as soon as we get it. Thus, the previous procedure is chopped in pieces. First piece: store the output unit and a flag whether we want to print to standard output as well. Then write the header if the results are still empty, i.e., before integration has started. The second piece writes a single result to the saved output channels. We call this from the [[record]] method, which can be called from the integrator directly. The third piece writes the average result, once a pass has been completed. The fourth piece writes a footer (if any), assuming that this is the final result. <>= procedure :: display_init => integration_results_display_init procedure :: display_current => integration_results_display_current procedure :: display_pass => integration_results_display_pass procedure :: display_final => integration_results_display_final <>= module subroutine integration_results_display_init & (results, screen, unit) class(integration_results_t), intent(inout) :: results logical, intent(in) :: screen integer, intent(in), optional :: unit end subroutine integration_results_display_init module subroutine integration_results_display_current (results, pacify) class(integration_results_t), intent(in) :: results logical, intent(in), optional :: pacify end subroutine integration_results_display_current module subroutine integration_results_display_pass (results, pacify) class(integration_results_t), intent(in) :: results logical, intent(in), optional :: pacify end subroutine integration_results_display_pass module subroutine integration_results_display_final (results) class(integration_results_t), intent(inout) :: results end subroutine integration_results_display_final <>= module subroutine integration_results_display_init & (results, screen, unit) class(integration_results_t), intent(inout) :: results logical, intent(in) :: screen integer, intent(in), optional :: unit integer :: u if (present (unit)) results%unit = unit u = given_output_unit () results%screen = screen if (results%n_it == 0) then if (results%screen) then call results%write_dline (u) call results%write_header (u, & logfile=.false.) call results%write_dline (u) end if if (results%unit /= 0) then call results%write_dline (results%unit) call results%write_header (results%unit, & logfile=.false.) call results%write_dline (results%unit) end if else if (results%screen) then call results%write_hline (u) end if if (results%unit /= 0) then call results%write_hline (results%unit) end if end if end subroutine integration_results_display_init module subroutine integration_results_display_current (results, pacify) class(integration_results_t), intent(in) :: results integer :: u logical, intent(in), optional :: pacify u = given_output_unit () if (results%screen) then call results%entry(results%n_it)%write (u, & verbosity = results%verbosity, suppress = pacify) end if if (results%unit /= 0) then call results%entry(results%n_it)%write ( & results%unit, verbosity = results%verbosity, suppress = pacify) end if end subroutine integration_results_display_current module subroutine integration_results_display_pass (results, pacify) class(integration_results_t), intent(in) :: results logical, intent(in), optional :: pacify integer :: u u = given_output_unit () if (results%screen) then call results%write_hline (u) call results%average(results%entry(results%n_it)%pass)%write ( & u, verbosity = results%verbosity, suppress = pacify) end if if (results%unit /= 0) then call results%write_hline (results%unit) call results%average(results%entry(results%n_it)%pass)%write ( & results%unit, verbosity = results%verbosity, suppress = pacify) end if end subroutine integration_results_display_pass module subroutine integration_results_display_final (results) class(integration_results_t), intent(inout) :: results integer :: u u = given_output_unit () if (results%screen) then call results%write_dline (u) end if if (results%unit /= 0) then call results%write_dline (results%unit) end if results%screen = .false. results%unit = 0 end subroutine integration_results_display_final @ %def integration_results_display_init @ %def integration_results_display_current @ %def integration_results_display_pass @ Expand the list of entries if the limit has been reached: <>= procedure :: expand => integration_results_expand <>= module subroutine integration_results_expand (results) class(integration_results_t), intent(inout) :: results end subroutine integration_results_expand <>= module subroutine integration_results_expand (results) class(integration_results_t), intent(inout) :: results type(integration_entry_t), dimension(:), allocatable :: entry_tmp if (results%n_it == size (results%entry)) then allocate (entry_tmp (results%n_it)) entry_tmp = results%entry deallocate (results%entry) allocate (results%entry (results%n_it + RESULTS_CHUNK_SIZE)) results%entry(:results%n_it) = entry_tmp deallocate (entry_tmp) end if if (results%n_pass == size (results%average)) then allocate (entry_tmp (results%n_pass)) entry_tmp = results%average deallocate (results%average) allocate (results%average (results%n_it + RESULTS_CHUNK_SIZE)) results%average(:results%n_pass) = entry_tmp deallocate (entry_tmp) end if end subroutine integration_results_expand @ %def integration_results_expand @ Increment the [[current_pass]] counter. Must be done before each new integration pass; after integration, the recording method may use the value of this counter to define the entry. <>= procedure :: new_pass => integration_results_new_pass <>= module subroutine integration_results_new_pass (results) class(integration_results_t), intent(inout) :: results end subroutine integration_results_new_pass <>= module subroutine integration_results_new_pass (results) class(integration_results_t), intent(inout) :: results results%current_pass = results%current_pass + 1 end subroutine integration_results_new_pass @ %def integration_results_new_pass @ Enter results into the results list. For the error value, we may compare them with a given threshold. This guards against numerical noise, if the exact error would be zero. <>= procedure :: append => integration_results_append <>= module subroutine integration_results_append (results, & n_it, n_calls, n_calls_valid, & integral, error, efficiency, efficiency_pos, efficiency_neg, & chain_weights) class(integration_results_t), intent(inout) :: results integer, intent(in) :: n_it, n_calls, n_calls_valid real(default), intent(in) :: integral, error, efficiency, & efficiency_pos, efficiency_neg real(default), dimension(:), intent(in), optional :: chain_weights end subroutine integration_results_append <>= module subroutine integration_results_append (results, & n_it, n_calls, n_calls_valid, & integral, error, efficiency, efficiency_pos, efficiency_neg, & chain_weights) class(integration_results_t), intent(inout) :: results integer, intent(in) :: n_it, n_calls, n_calls_valid real(default), intent(in) :: integral, error, efficiency, & efficiency_pos, efficiency_neg real(default), dimension(:), intent(in), optional :: chain_weights logical :: improved type(integration_entry_t) :: entry real(default) :: err_checked improved = .true. if (results%n_it /= 0) improved = abs(accuracy (integral, error, n_calls)) & < abs(results%entry(results%n_it)%get_accuracy ()) err_checked = 0 if (abs (error) >= results%error_threshold) err_checked = error entry = integration_entry_t ( & results%process_type, results%current_pass, & results%n_it+1, n_it, n_calls, n_calls_valid, improved, & integral, err_checked, efficiency, efficiency_pos, efficiency_neg, & chain_weights=chain_weights) if (results%n_it == 0) then results%n_it = 1 results%n_pass = 1 else call results%expand () if (entry%pass /= results%entry(results%n_it)%pass) & results%n_pass = results%n_pass + 1 results%n_it = results%n_it + 1 end if results%entry(results%n_it) = entry results%average(results%n_pass) = & compute_average (results%entry, entry%pass) end subroutine integration_results_append @ %def integration_results_append @ Record an integration pass executed by an [[mci]] integrator object. There is a tolerance below we treat an error (relative to the integral) as zero. <>= real(default), parameter, public :: INTEGRATION_ERROR_TOLERANCE = 1e-10 @ %def INTEGRATION_ERROR_TOLERANCE @ <>= procedure :: record_simple => integration_results_record_simple <>= module subroutine integration_results_record_simple & (object, n_it, n_calls, integral, error, efficiency, & chain_weights, suppress) class(integration_results_t), intent(inout) :: object integer, intent(in) :: n_it, n_calls real(default), intent(in) :: integral, error, efficiency real(default), dimension(:), intent(in), optional :: chain_weights logical, intent(in), optional :: suppress end subroutine integration_results_record_simple <>= module subroutine integration_results_record_simple & (object, n_it, n_calls, integral, error, efficiency, & chain_weights, suppress) class(integration_results_t), intent(inout) :: object integer, intent(in) :: n_it, n_calls real(default), intent(in) :: integral, error, efficiency real(default), dimension(:), intent(in), optional :: chain_weights logical, intent(in), optional :: suppress real(default) :: err err = 0._default if (abs (error) >= abs (integral) * INTEGRATION_ERROR_TOLERANCE) then err = error end if call object%append (n_it, n_calls, 0, integral, err, efficiency, & 0._default, 0._default, chain_weights) call object%display_current (suppress) end subroutine integration_results_record_simple @ %def integration_results_record_simple @ Record extended results from integration pass. <>= procedure :: record_extended => integration_results_record_extended <>= module subroutine integration_results_record_extended (object, n_it, & n_calls, n_calls_valid, integral, error, efficiency, efficiency_pos, & efficiency_neg, chain_weights, suppress) class(integration_results_t), intent(inout) :: object integer, intent(in) :: n_it, n_calls, n_calls_valid real(default), intent(in) :: integral, error, efficiency, & efficiency_pos, efficiency_neg real(default), dimension(:), intent(in), optional :: chain_weights logical, intent(in), optional :: suppress end subroutine integration_results_record_extended <>= module subroutine integration_results_record_extended (object, n_it, & n_calls, n_calls_valid, integral, error, efficiency, efficiency_pos, & efficiency_neg, chain_weights, suppress) class(integration_results_t), intent(inout) :: object integer, intent(in) :: n_it, n_calls, n_calls_valid real(default), intent(in) :: integral, error, efficiency, & efficiency_pos, efficiency_neg real(default), dimension(:), intent(in), optional :: chain_weights logical, intent(in), optional :: suppress real(default) :: err err = 0._default if (abs (error) >= abs (integral) * INTEGRATION_ERROR_TOLERANCE) then err = error end if call object%append (n_it, n_calls, n_calls_valid, integral, err, & efficiency, efficiency_pos, efficiency_neg, chain_weights) call object%display_current (suppress) end subroutine integration_results_record_extended @ %def integration_results_record_extended @ Compute the average for all entries in the specified integration pass. The integrals are weighted w.r.t.\ their individual errors. The quoted error of the result is the expected error, computed from the weighted average of the given individual errors. This should be compared to the actual distribution of the results, from which we also can compute an error estimate if there is more than one iteration. The ratio of the distribution error and the averaged error, is the $\chi^2$ value. All error distributions are assumed Gaussian, of course. The $\chi^2$ value is a partial check for this assumption. If it is significantly greater than unity, there is something wrong with the individual errors. The efficiency returned is the one of the last entry in the integration pass. If any error vanishes, averaging by this algorithm would fail. In this case, we simply average the entries and use the deviations from this average (if any) to estimate the error. <>= type(integration_entry_t) function compute_average (entry, pass) & & result (result) type(integration_entry_t), dimension(:), intent(in) :: entry integer, intent(in) :: pass integer :: i logical, dimension(size(entry)) :: mask real(default), dimension(size(entry)) :: ivar real(default) :: sum_ivar, variance result%process_type = entry(1)%process_type result%pass = pass mask = entry%pass == pass .and. entry%process_type /= PRC_UNKNOWN result%it = maxval (entry%it, mask) result%n_it = count (mask) result%n_calls = sum (entry%n_calls, mask) result%n_calls_valid = sum (entry%n_calls_valid, mask) if (.not. any (mask .and. entry%error == 0)) then where (mask) ivar = 1 / entry%error ** 2 elsewhere ivar = 0 end where sum_ivar = sum (ivar, mask) variance = 0 if (sum_ivar /= 0) then variance = 1 / sum_ivar end if result%integral = sum (entry%integral * ivar, mask) * variance if (result%n_it > 1) then result%chi2 = & sum ((entry%integral - result%integral)**2 * ivar, mask) & / (result%n_it - 1) end if else if (result%n_it /= 0) then result%integral = sum (entry%integral, mask) / result%n_it variance = 0 if (result%n_it > 1) then variance = & sum ((entry%integral - result%integral)**2, mask) & / (result%n_it - 1) if (result%integral /= 0) then if (abs (variance / result%integral) & < 100 * epsilon (1._default)) then variance = 0 end if end if end if result%chi2 = variance / result%n_it end if result%error = sqrt (variance) result%efficiency = entry(last_index (mask))%efficiency result%efficiency_pos = entry(last_index (mask))%efficiency_pos result%efficiency_neg = entry(last_index (mask))%efficiency_neg contains integer function last_index (mask) result (index) logical, dimension(:), intent(in) :: mask integer :: i do i = size (mask), 1, -1 if (mask(i)) exit end do index = i end function last_index end function compute_average @ %def compute_average @ \subsection{Access results} Return true if the results object has entries. <>= procedure :: exist => integration_results_exist <>= module function integration_results_exist (results) result (flag) logical :: flag class(integration_results_t), intent(in) :: results end function integration_results_exist <>= module function integration_results_exist (results) result (flag) logical :: flag class(integration_results_t), intent(in) :: results flag = results%n_pass > 0 end function integration_results_exist @ %def integration_results_exist @ Retrieve information from the results record. If [[last]] is set and true, take the last iteration. If [[it]] is set instead, take this iteration. If [[pass]] is set, take this average. If none is set, take the final average. If the result would be invalid, the entry is not assigned. Due to default initialization, this returns a null entry. <>= procedure :: get_entry => results_get_entry <>= module function results_get_entry (results, last, it, pass) result (entry) class(integration_results_t), intent(in) :: results type(integration_entry_t) :: entry logical, intent(in), optional :: last integer, intent(in), optional :: it, pass end function results_get_entry <>= module function results_get_entry (results, last, it, pass) result (entry) class(integration_results_t), intent(in) :: results type(integration_entry_t) :: entry logical, intent(in), optional :: last integer, intent(in), optional :: it, pass if (present (last)) then if (allocated (results%entry) .and. results%n_it > 0) then entry = results%entry(results%n_it) else call error () end if else if (present (it)) then if (allocated (results%entry) .and. it > 0 .and. it <= results%n_it) then entry = results%entry(it) else call error () end if else if (present (pass)) then if (allocated (results%average) & .and. pass > 0 .and. pass <= results%n_pass) then entry = results%average (pass) else call error () end if else if (allocated (results%average) .and. results%n_pass > 0) then entry = results%average (results%n_pass) else call error () end if end if contains subroutine error () call msg_fatal ("Requested integration result is not available") end subroutine error end function results_get_entry @ %def results_get_entry @ The individual procedures. The [[results]] record should have the [[target]] attribute, but only locally within the function. <>= procedure :: get_n_calls => integration_results_get_n_calls procedure :: get_integral => integration_results_get_integral procedure :: get_error => integration_results_get_error procedure :: get_accuracy => integration_results_get_accuracy procedure :: get_chi2 => integration_results_get_chi2 procedure :: get_efficiency => integration_results_get_efficiency <>= module function integration_results_get_n_calls (results, last, it, pass) & result (n_calls) class(integration_results_t), intent(in), target :: results integer :: n_calls logical, intent(in), optional :: last integer, intent(in), optional :: it, pass end function integration_results_get_n_calls module function integration_results_get_integral (results, last, it, pass) & result (integral) class(integration_results_t), intent(in), target :: results real(default) :: integral logical, intent(in), optional :: last integer, intent(in), optional :: it, pass end function integration_results_get_integral module function integration_results_get_error (results, last, it, pass) & result (error) class(integration_results_t), intent(in), target :: results real(default) :: error logical, intent(in), optional :: last integer, intent(in), optional :: it, pass end function integration_results_get_error module function integration_results_get_accuracy (results, last, it, pass) & result (accuracy) class(integration_results_t), intent(in), target :: results real(default) :: accuracy logical, intent(in), optional :: last integer, intent(in), optional :: it, pass end function integration_results_get_accuracy module function integration_results_get_chi2 (results, last, it, pass) & result (chi2) class(integration_results_t), intent(in), target :: results real(default) :: chi2 logical, intent(in), optional :: last integer, intent(in), optional :: it, pass end function integration_results_get_chi2 module function integration_results_get_efficiency & (results, last, it, pass) result (efficiency) class(integration_results_t), intent(in), target :: results real(default) :: efficiency logical, intent(in), optional :: last integer, intent(in), optional :: it, pass end function integration_results_get_efficiency <>= module function integration_results_get_n_calls (results, last, it, pass) & result (n_calls) class(integration_results_t), intent(in), target :: results integer :: n_calls logical, intent(in), optional :: last integer, intent(in), optional :: it, pass type(integration_entry_t) :: entry entry = results%get_entry (last, it, pass) n_calls = entry%get_n_calls () end function integration_results_get_n_calls module function integration_results_get_integral (results, last, it, pass) & result (integral) class(integration_results_t), intent(in), target :: results real(default) :: integral logical, intent(in), optional :: last integer, intent(in), optional :: it, pass type(integration_entry_t) :: entry entry = results%get_entry (last, it, pass) integral = entry%get_integral () end function integration_results_get_integral module function integration_results_get_error (results, last, it, pass) & result (error) class(integration_results_t), intent(in), target :: results real(default) :: error logical, intent(in), optional :: last integer, intent(in), optional :: it, pass type(integration_entry_t) :: entry entry = results%get_entry (last, it, pass) error = entry%get_error () end function integration_results_get_error module function integration_results_get_accuracy (results, last, it, pass) & result (accuracy) class(integration_results_t), intent(in), target :: results real(default) :: accuracy logical, intent(in), optional :: last integer, intent(in), optional :: it, pass type(integration_entry_t) :: entry entry = results%get_entry (last, it, pass) accuracy = entry%get_accuracy () end function integration_results_get_accuracy module function integration_results_get_chi2 (results, last, it, pass) & result (chi2) class(integration_results_t), intent(in), target :: results real(default) :: chi2 logical, intent(in), optional :: last integer, intent(in), optional :: it, pass type(integration_entry_t) :: entry entry = results%get_entry (last, it, pass) chi2 = entry%get_chi2 () end function integration_results_get_chi2 module function integration_results_get_efficiency (results, last, it, pass) & result (efficiency) class(integration_results_t), intent(in), target :: results real(default) :: efficiency logical, intent(in), optional :: last integer, intent(in), optional :: it, pass type(integration_entry_t) :: entry entry = results%get_entry (last, it, pass) efficiency = entry%get_efficiency () end function integration_results_get_efficiency @ %def integration_results_get_n_calls @ %def integration_results_get_integral @ %def integration_results_get_error @ %def integration_results_get_accuracy @ %def integration_results_get_chi2 @ %def integration_results_get_efficiency @ Return the last pass index and the index of the last iteration \emph{within} the last pass. The third routine returns the absolute index of the last iteration. <>= function integration_results_get_current_pass (results) result (pass) integer :: pass type(integration_results_t), intent(in) :: results pass = results%n_pass end function integration_results_get_current_pass function integration_results_get_current_it (results) result (it) integer :: it type(integration_results_t), intent(in) :: results it = 0 if (allocated (results%entry)) then it = count (results%entry(1:results%n_it)%pass == results%n_pass) end if end function integration_results_get_current_it function integration_results_get_last_it (results) result (it) integer :: it type(integration_results_t), intent(in) :: results it = results%n_it end function integration_results_get_last_it @ %def integration_results_get_current_pass @ %def integration_results_get_current_it @ %def integration_results_get_last_it @ Return the index of the best iteration (lowest accuracy value) within the current pass. If none qualifies, return zero. <>= function integration_results_get_best_it (results) result (it) integer :: it type(integration_results_t), intent(in) :: results integer :: i real(default) :: acc, acc_best acc_best = -1 it = 0 do i = 1, results%n_it if (results%entry(i)%pass == results%n_pass) then acc = integration_entry_get_accuracy (results%entry(i)) if (acc_best < 0 .or. acc <= acc_best) then acc_best = acc it = i end if end if end do end function integration_results_get_best_it @ %def integration_results_get_best_it @ Compute the MD5 sum by printing everything and checksumming the resulting file. <>= function integration_results_get_md5sum (results) result (md5sum_results) character(32) :: md5sum_results type(integration_results_t), intent(in) :: results integer :: u u = free_unit () open (unit = u, status = "scratch", action = "readwrite") call results%write_verbose (u) rewind (u) md5sum_results = md5sum (u) close (u) end function integration_results_get_md5sum @ %def integration_results_get_md5sum @ This is (ab)used to suppress numerical noise when integrating constant matrix elements. <>= procedure :: pacify => integration_results_pacify <>= module subroutine integration_results_pacify (results, efficiency_reset) class(integration_results_t), intent(inout) :: results logical, intent(in), optional :: efficiency_reset end subroutine integration_results_pacify <>= module subroutine integration_results_pacify (results, efficiency_reset) class(integration_results_t), intent(inout) :: results logical, intent(in), optional :: efficiency_reset integer :: i logical :: reset reset = .false. if (present (efficiency_reset)) reset = efficiency_reset if (allocated (results%entry)) then do i = 1, size (results%entry) call pacify (results%entry(i)%error, & results%entry(i)%integral * 1.E-9_default) if (reset) results%entry(i)%efficiency = 1 end do end if if (allocated (results%average)) then do i = 1, size (results%average) call pacify (results%average(i)%error, & results%average(i)%integral * 1.E-9_default) if (reset) results%average(i)%efficiency = 1 end do end if end subroutine integration_results_pacify @ %def integration_results_pacify @ <>= procedure :: record_correction => integration_results_record_correction <>= module subroutine integration_results_record_correction (object, corr, err) class(integration_results_t), intent(inout) :: object real(default), intent(in) :: corr, err end subroutine integration_results_record_correction <>= module subroutine integration_results_record_correction (object, corr, err) class(integration_results_t), intent(inout) :: object real(default), intent(in) :: corr, err integer :: u u = given_output_unit () if (object%screen) then call object%write_hline (u) call msg_message ("NLO Correction: [O(alpha_s+1)/O(alpha_s)]") write(msg_buffer,'(1X,A1,F7.2,A4,F6.2,1X,A3)') '(', corr, ' +- ', err, ') %' call msg_message () end if end subroutine integration_results_record_correction @ %def integration_results_record_correction @ \subsection{Results display} Write a driver file for history visualization. The ratio of $y$ range over $y$ value must not become too small, otherwise we run into an arithmetic overflow in GAMELAN. 2\% appears to be safe. <>= real, parameter, public :: GML_MIN_RANGE_RATIO = 0.02 <>= public :: integration_results_write_driver <>= module subroutine integration_results_write_driver & (results, filename, eff_reset) type(integration_results_t), intent(inout) :: results type(string_t), intent(in) :: filename logical, intent(in), optional :: eff_reset end subroutine integration_results_write_driver <>= module subroutine integration_results_write_driver & (results, filename, eff_reset) type(integration_results_t), intent(inout) :: results type(string_t), intent(in) :: filename logical, intent(in), optional :: eff_reset type(string_t) :: file_tex integer :: unit integer :: n, i, n_pass, pass integer, dimension(:), allocatable :: ipass real(default) :: ymin, ymax, yavg, ydif, y0, y1 real(default), dimension(results%n_it) :: ymin_arr, ymax_arr logical :: reset file_tex = filename // ".tex" unit = free_unit () open (unit=unit, file=char(file_tex), action="write", status="replace") reset = .false.; if (present (eff_reset)) reset = eff_reset n = results%n_it n_pass = results%n_pass allocate (ipass (results%n_pass)) ipass(1) = 0 pass = 2 do i = 1, n-1 if (integration_entry_get_pass (results%entry(i)) & /= integration_entry_get_pass (results%entry(i+1))) then ipass(pass) = i pass = pass + 1 end if end do ymin_arr = integration_entry_get_integral (results%entry(:n)) & - integration_entry_get_error (results%entry(:n)) ymin = minval (ymin_arr) ymax_arr = integration_entry_get_integral (results%entry(:n)) & + integration_entry_get_error (results%entry(:n)) ymax = maxval (ymax_arr) yavg = (ymax + ymin) / 2 ydif = (ymax - ymin) if (ydif * 1.5 > GML_MIN_RANGE_RATIO * yavg) then y0 = yavg - ydif * 0.75 y1 = yavg + ydif * 0.75 else y0 = yavg * (1 - GML_MIN_RANGE_RATIO / 2) y1 = yavg * (1 + GML_MIN_RANGE_RATIO / 2) end if write (unit, "(A)") "\documentclass{article}" write (unit, "(A)") "\usepackage{a4wide}" write (unit, "(A)") "\usepackage{gamelan}" write (unit, "(A)") "\usepackage{amsmath}" write (unit, "(A)") "" write (unit, "(A)") "\begin{document}" write (unit, "(A)") "\begin{gmlfile}" write (unit, "(A)") "\section*{Integration Results Display}" write (unit, "(A)") "" write (unit, "(A)") "Process: \verb|" // char (filename) // "|" write (unit, "(A)") "" write (unit, "(A)") "\vspace*{2\baselineskip}" write (unit, "(A)") "\unitlength 1mm" write (unit, "(A)") "\begin{gmlcode}" write (unit, "(A)") " picture sym; sym = fshape (circle scaled 1mm)();" write (unit, "(A)") " color col.band; col.band = 0.9white;" write (unit, "(A)") " color col.eband; col.eband = 0.98white;" write (unit, "(A)") "\end{gmlcode}" write (unit, "(A)") "\begin{gmlgraph*}(130,180)[history]" write (unit, "(A)") " setup (linear, linear);" write (unit, "(A,I0,A)") " history.n_pass = ", n_pass, ";" write (unit, "(A,I0,A)") " history.n_it = ", n, ";" write (unit, "(A,A,A)") " history.y0 = #""", char (mp_format (y0)), """;" write (unit, "(A,A,A)") " history.y1 = #""", char (mp_format (y1)), """;" write (unit, "(A)") & " graphrange (#0.5, history.y0), (#(n+0.5), history.y1);" do pass = 1, n_pass write (unit, "(A,I0,A,I0,A)") & " history.pass[", pass, "] = ", ipass(pass), ";" write (unit, "(A,I0,A,A,A)") & " history.avg[", pass, "] = #""", & char (mp_format & (integration_entry_get_integral (results%average(pass)))), & """;" write (unit, "(A,I0,A,A,A)") & " history.err[", pass, "] = #""", & char (mp_format & (integration_entry_get_error (results%average(pass)))), & """;" write (unit, "(A,I0,A,A,A)") & " history.chi[", pass, "] = #""", & char (mp_format & (integration_entry_get_chi2 (results%average(pass)))), & """;" end do write (unit, "(A,I0,A,I0,A)") & " history.pass[", n_pass + 1, "] = ", n, ";" write (unit, "(A)") " for i = 1 upto history.n_pass:" write (unit, "(A)") " if history.chi[i] greater one:" write (unit, "(A)") " fill plot (" write (unit, "(A)") & " (#(history.pass[i] +.5), " & // "history.avg[i] minus history.err[i] times history.chi[i])," write (unit, "(A)") & " (#(history.pass[i+1]+.5), " & // "history.avg[i] minus history.err[i] times history.chi[i])," write (unit, "(A)") & " (#(history.pass[i+1]+.5), " & // "history.avg[i] plus history.err[i] times history.chi[i])," write (unit, "(A)") & " (#(history.pass[i] +.5), " & // "history.avg[i] plus history.err[i] times history.chi[i])" write (unit, "(A)") " ) withcolor col.eband fi;" write (unit, "(A)") " fill plot (" write (unit, "(A)") & " (#(history.pass[i] +.5), history.avg[i] minus history.err[i])," write (unit, "(A)") & " (#(history.pass[i+1]+.5), history.avg[i] minus history.err[i])," write (unit, "(A)") & " (#(history.pass[i+1]+.5), history.avg[i] plus history.err[i])," write (unit, "(A)") & " (#(history.pass[i] +.5), history.avg[i] plus history.err[i])" write (unit, "(A)") " ) withcolor col.band;" write (unit, "(A)") " draw plot (" write (unit, "(A)") & " (#(history.pass[i] +.5), history.avg[i])," write (unit, "(A)") & " (#(history.pass[i+1]+.5), history.avg[i])" write (unit, "(A)") " ) dashed evenly;" write (unit, "(A)") " endfor" write (unit, "(A)") " for i = 1 upto history.n_pass + 1:" write (unit, "(A)") " draw plot (" write (unit, "(A)") & " (#(history.pass[i]+.5), history.y0)," write (unit, "(A)") & " (#(history.pass[i]+.5), history.y1)" write (unit, "(A)") " ) dashed withdots;" write (unit, "(A)") " endfor" do i = 1, n write (unit, "(A,I0,A,A,A,A,A)") " plot (history) (#", & i, ", #""", & char (mp_format (integration_entry_get_integral (results%entry(i)))),& """) vbar #""", & char (mp_format (integration_entry_get_error (results%entry(i)))), & """;" end do write (unit, "(A)") " draw piecewise from (history) " & // "withsymbol sym;" write (unit, "(A)") " fullgrid.lr (5,20);" write (unit, "(A)") " standardgrid.bt (n);" write (unit, "(A)") " begingmleps ""Whizard-Logo.eps"";" write (unit, "(A)") " base := (120*unitlength,170*unitlength);" write (unit, "(A)") " height := 9.6*unitlength;" write (unit, "(A)") " width := 11.2*unitlength;" write (unit, "(A)") " endgmleps;" write (unit, "(A)") "\end{gmlgraph*}" write (unit, "(A)") "\end{gmlfile}" write (unit, "(A)") "\clearpage" write (unit, "(A)") "\begin{verbatim}" if (reset) then call results%pacify (reset) end if call integration_results_write (results, unit) write (unit, "(A)") "\end{verbatim}" write (unit, "(A)") "\end{document}" close (unit) end subroutine integration_results_write_driver @ %def integration_results_write_driver @ Call \LaTeX\ and Metapost for the history driver file, and convert to PS and PDF. <>= public :: integration_results_compile_driver <>= module subroutine integration_results_compile_driver & (results, filename, os_data) type(integration_results_t), intent(in) :: results type(string_t), intent(in) :: filename type(os_data_t), intent(in) :: os_data end subroutine integration_results_compile_driver <>= module subroutine integration_results_compile_driver & (results, filename, os_data) type(integration_results_t), intent(in) :: results type(string_t), intent(in) :: filename type(os_data_t), intent(in) :: os_data integer :: unit_dev, status type(string_t) :: file_tex, file_dvi, file_ps, file_pdf, file_mp type(string_t) :: setenv_tex, setenv_mp, pipe, pipe_dvi if (.not. os_data%event_analysis) then call msg_warning ("Skipping integration history display " & // "because latex or mpost is not available") return end if file_tex = filename // ".tex" file_dvi = filename // ".dvi" file_ps = filename // ".ps" file_pdf = filename // ".pdf" file_mp = filename // ".mp" call msg_message ("Creating integration history display "& // char (file_ps) // " and " // char (file_pdf)) BLOCK: do unit_dev = free_unit () open (file = "/dev/null", unit = unit_dev, & action = "write", iostat = status) if (status /= 0) then pipe = "" pipe_dvi = "" else pipe = " > /dev/null" pipe_dvi = " 2>/dev/null 1>/dev/null" end if close (unit_dev) if (os_data%whizard_texpath /= "") then setenv_tex = & "TEXINPUTS=" // os_data%whizard_texpath // ":$TEXINPUTS " setenv_mp = & "MPINPUTS=" // os_data%whizard_texpath // ":$MPINPUTS " else setenv_tex = "" setenv_mp = "" end if call os_system_call (setenv_tex // os_data%latex // " " // & file_tex // pipe, status) if (status /= 0) exit BLOCK if (os_data%gml /= "") then call os_system_call (setenv_mp // os_data%gml // " " // & file_mp // pipe, status) else call msg_error ("Could not use GAMELAN/MetaPOST.") exit BLOCK end if if (status /= 0) exit BLOCK call os_system_call (setenv_tex // os_data%latex // " " // & file_tex // pipe, status) if (status /= 0) exit BLOCK if (os_data%event_analysis_ps) then call os_system_call (os_data%dvips // " " // & file_dvi // pipe_dvi, status) if (status /= 0) exit BLOCK else call msg_warning ("Skipping PostScript generation because dvips " & // "is not available") exit BLOCK end if if (os_data%event_analysis_pdf) then call os_system_call (os_data%ps2pdf // " " // & file_ps, status) if (status /= 0) exit BLOCK else call msg_warning ("Skipping PDF generation because ps2pdf " & // "is not available") exit BLOCK end if exit BLOCK end do BLOCK if (status /= 0) then call msg_error ("Unable to compile integration history display") end if end subroutine integration_results_compile_driver @ %def integration_results_compile_driver @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[integration_results_ut.f90]]>>= <> module integration_results_ut use unit_tests use integration_results_uti <> <> contains <> end module integration_results_ut @ %def integration_results_ut @ <<[[integration_results_uti.f90]]>>= <> module integration_results_uti <> use integration_results <> <> contains <> end module integration_results_uti @ %def integration_results_ut @ API: driver for the unit tests below. <>= public :: integration_results_test <>= subroutine integration_results_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine integration_results_test @ %def integration_results_test @ \subsubsection{Integration entry} <>= call test (integration_results_1, "integration_results_1", & "record single line and write to log", & u, results) <>= public :: integration_results_1 <>= subroutine integration_results_1 (u) integer, intent(in) :: u type(integration_entry_t) :: entry write (u, "(A)") "* Test output: integration_results_1" write (u, "(A)") "* Purpose: record single entry and write to log" write (u, "(A)") write (u, "(A)") "* Write single line output" write (u, "(A)") entry = integration_entry_t ( & & process_type = 1, & & pass = 1, & & it = 1, & & n_it = 10, & & n_calls = 1000, & & n_calls_valid = 500, & & improved = .true., & & integral = 1.0_default, & & error = 0.5_default, & & efficiency = 0.25_default, & & efficiency_pos = 0.22_default, & & efficiency_neg = 0.03_default) call entry%write (u, 3) write (u, "(A)") write (u, "(A)") "* Test output end: integration_results_1" end subroutine integration_results_1 @ %def integration_results_1 @ <>= call test (integration_results_2, "integration_results_2", & "record single result and write to log", & u, results) <>= public :: integration_results_2 <>= subroutine integration_results_2 (u) integer, intent(in) :: u type(integration_results_t) :: results write (u, "(A)") "* Test output: integration_results_2" write (u, "(A)") "* Purpose: record single result and write to log" write (u, "(A)") write (u, "(A)") "* Write single line output" write (u, "(A)") call results%init (PRC_DECAY) call results%append (1, 250, 0, 1.0_default, 0.5_default, 0.25_default,& & 0._default, 0._default) call results%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: integration_results_2" end subroutine integration_results_2 @ %def integration_results_2 @ <>= call test (integration_results_3, "integration_results_3", & "initialize display and add/display each entry", & u, results) <>= public :: integration_results_3 <>= subroutine integration_results_3 (u) integer, intent(in) :: u type(integration_results_t) :: results write (u, "(A)") "* Test output: integration_results_2" write (u, "(A)") "* Purpose: intialize display, record three entries,& & display pass average and finalize display" write (u, "(A)") write (u, "(A)") "* Initialize display and add entry" write (u, "(A)") call results%init (PRC_DECAY) call results%set_verbosity (1) call results%display_init (screen = .false., unit = u) call results%new_pass () call results%record (1, 250, 1.0_default, 0.5_default, 0.25_default) call results%record (1, 250, 1.1_default, 0.5_default, 0.25_default) call results%record (1, 250, 0.9_default, 0.5_default, 0.25_default) write (u, "(A)") write (u, "(A)") "* Display pass" write (u, "(A)") call results%display_pass () write (u, "(A)") write (u, "(A)") "* Finalize displays" write (u, "(A)") call results%display_final () write (u, "(A)") write (u, "(A)") "* Test output end: integration_results_3" end subroutine integration_results_3 @ %def integration_results_3 @ <>= call test (integration_results_4, "integration_results_4", & "record extended results and display", & u, results) <>= public :: integration_results_4 <>= subroutine integration_results_4 (u) integer, intent(in) :: u type(integration_results_t) :: results write (u, "(A)") "* Test output: integration_results_4" write (u, "(A)") "* Purpose: record extended results and display with verbosity = 2" write (u, "(A)") write (u, "(A)") "* Initialize display and record extended result" write (u, "(A)") call results%init (PRC_DECAY) call results%set_verbosity (2) call results%display_init (screen = .false., unit = u) call results%new_pass () call results%record (1, 250, 150, 1.0_default, 0.5_default, 0.25_default,& & 0.22_default, 0.03_default) call results%record (1, 250, 180, 1.1_default, 0.5_default, 0.25_default,& & 0.23_default, 0.02_default) call results%record (1, 250, 130, 0.9_default, 0.5_default, 0.25_default,& & 0.25_default, 0.00_default) write (u, "(A)") write (u, "(A)") "* Display pass" write (u, "(A)") call results%display_pass () write (u, "(A)") write (u, "(A)") "* Finalize displays" write (u, "(A)") call results%display_final () write (u, "(A)") write (u, "(A)") "* Test output end: integration_results_4" end subroutine integration_results_4 @ %def integration_results_4 @ <>= call test (integration_results_5, "integration_results_5", & "record extended results and display", & u, results) <>= public :: integration_results_5 <>= subroutine integration_results_5 (u) integer, intent(in) :: u type(integration_results_t) :: results write (u, "(A)") "* Test output: integration_results_5" write (u, "(A)") "* Purpose: record extended results and display with verbosity = 3" write (u, "(A)") write (u, "(A)") "* Initialize display and record extended result" write (u, "(A)") call results%init (PRC_DECAY) call results%set_verbosity (3) call results%display_init (screen = .false., unit = u) call results%new_pass () call results%record (1, 250, 150, 1.0_default, 0.5_default, 0.25_default,& & 0.22_default, 0.03_default) call results%record (1, 250, 180, 1.1_default, 0.5_default, 0.25_default,& & 0.23_default, 0.02_default) call results%record (1, 250, 130, 0.9_default, 0.5_default, 0.25_default,& & 0.25_default, 0.00_default) call results%display_pass () call results%display_final () write (u, "(A)") write (u, "(A)") "* Test output end: integration_results_5" end subroutine integration_results_5 @ %def integration_results_5 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Dummy integrator} This implementation acts as a placeholder for cases where no integration or event generation is required at all. <<[[mci_none.f90]]>>= <> module mci_none <> use io_units, only: given_output_unit use phs_base, only: phs_channel_t use mci_base <> <> <> interface <> end interface contains <> end module mci_none @ %def mci_none @ <<[[mci_none_sub.f90]]>>= <> submodule (mci_none) mci_none_s use diagnostics, only: msg_message, msg_fatal implicit none contains <> end submodule mci_none_s @ %def mci_none_s @ \subsection{Integrator} The object contains the methods for integration and event generation. For the actual work and data storage, it spawns an instance object. After an integration pass, we update the [[max]] parameter to indicate the maximum absolute value of the integrand that the integrator encountered. This is required for event generation. <>= public :: mci_none_t <>= type, extends (mci_t) :: mci_none_t contains <> end type mci_none_t @ %def mci_t @ Finalizer: no-op. <>= procedure :: final => mci_none_final <>= module subroutine mci_none_final (object) class(mci_none_t), intent(inout) :: object end subroutine mci_none_final <>= module subroutine mci_none_final (object) class(mci_none_t), intent(inout) :: object end subroutine mci_none_final @ %def mci_none_final @ Output. <>= procedure :: write => mci_none_write <>= module subroutine mci_none_write (object, unit, pacify, md5sum_version) class(mci_none_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version end subroutine mci_none_write <>= module subroutine mci_none_write (object, unit, pacify, md5sum_version) class(mci_none_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Integrator: non-functional dummy" end subroutine mci_none_write @ %def mci_none_write @ Startup message: short version. <>= procedure :: startup_message => mci_none_startup_message <>= module subroutine mci_none_startup_message (mci, unit, n_calls) class(mci_none_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls end subroutine mci_none_startup_message <>= module subroutine mci_none_startup_message (mci, unit, n_calls) class(mci_none_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls call msg_message ("Integrator: none") end subroutine mci_none_startup_message @ %def mci_none_startup_message @ Log entry: just headline. <>= procedure :: write_log_entry => mci_none_write_log_entry <>= module subroutine mci_none_write_log_entry (mci, u) class(mci_none_t), intent(in) :: mci integer, intent(in) :: u end subroutine mci_none_write_log_entry <>= module subroutine mci_none_write_log_entry (mci, u) class(mci_none_t), intent(in) :: mci integer, intent(in) :: u write (u, "(1x,A)") "MC Integrator is none (no-op)" end subroutine mci_none_write_log_entry @ %def mci_none_write_log_entry @ MD5 sum: nothing. <>= procedure :: compute_md5sum => mci_none_compute_md5sum <>= module subroutine mci_none_compute_md5sum (mci, pacify) class(mci_none_t), intent(inout) :: mci logical, intent(in), optional :: pacify end subroutine mci_none_compute_md5sum <>= module subroutine mci_none_compute_md5sum (mci, pacify) class(mci_none_t), intent(inout) :: mci logical, intent(in), optional :: pacify end subroutine mci_none_compute_md5sum @ %def mci_none_compute_md5sum @ The number of channels must be one. <>= procedure :: set_dimensions => mci_none_set_dimensions <>= subroutine mci_none_set_dimensions (mci, n_dim, n_channel) class(mci_none_t), intent(inout) :: mci integer, intent(in) :: n_dim integer, intent(in) :: n_channel if (n_channel == 1) then mci%n_channel = n_channel mci%n_dim = n_dim allocate (mci%dim_is_binned (mci%n_dim)) mci%dim_is_binned = .true. mci%n_dim_binned = count (mci%dim_is_binned) allocate (mci%n_bin (mci%n_dim)) mci%n_bin = 0 else call msg_fatal ("Attempt to initialize single-channel integrator & &for multiple channels") end if end subroutine mci_none_set_dimensions @ %def mci_none_set_dimensions @ Required by API. <>= procedure :: declare_flat_dimensions => mci_none_ignore_flat_dimensions <>= module subroutine mci_none_ignore_flat_dimensions (mci, dim_flat) class(mci_none_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat end subroutine mci_none_ignore_flat_dimensions <>= module subroutine mci_none_ignore_flat_dimensions (mci, dim_flat) class(mci_none_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat end subroutine mci_none_ignore_flat_dimensions @ %def mci_none_ignore_flat_dimensions @ Required by API. <>= procedure :: declare_equivalences => mci_none_ignore_equivalences <>= module subroutine mci_none_ignore_equivalences (mci, channel, dim_offset) class(mci_none_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset end subroutine mci_none_ignore_equivalences <>= module subroutine mci_none_ignore_equivalences (mci, channel, dim_offset) class(mci_none_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset end subroutine mci_none_ignore_equivalences @ %def mci_none_ignore_equivalences @ Allocate instance with matching type. Gfortran 7/8/9 bug: has to remain in the main module. <>= procedure :: allocate_instance => mci_none_allocate_instance <>= subroutine mci_none_allocate_instance (mci, mci_instance) class(mci_none_t), intent(in) :: mci class(mci_instance_t), intent(out), pointer :: mci_instance allocate (mci_none_instance_t :: mci_instance) end subroutine mci_none_allocate_instance @ %def mci_none_allocate_instance @ Integrate. This must not be called at all. <>= procedure :: integrate => mci_none_integrate <>= module subroutine mci_none_integrate (mci, instance, sampler, n_it, & n_calls, results, pacify) class(mci_none_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: pacify class(mci_results_t), intent(inout), optional :: results end subroutine mci_none_integrate <>= module subroutine mci_none_integrate (mci, instance, sampler, n_it, & n_calls, results, pacify) class(mci_none_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: pacify class(mci_results_t), intent(inout), optional :: results call msg_fatal & ("Integration: attempt to integrate with the 'mci_none' method") end subroutine mci_none_integrate @ %def mci_none_integrate @ Simulation initializer and finalizer: nothing to do here. <>= procedure :: prepare_simulation => mci_none_ignore_prepare_simulation <>= module subroutine mci_none_ignore_prepare_simulation (mci) class(mci_none_t), intent(inout) :: mci end subroutine mci_none_ignore_prepare_simulation <>= module subroutine mci_none_ignore_prepare_simulation (mci) class(mci_none_t), intent(inout) :: mci end subroutine mci_none_ignore_prepare_simulation @ %def mci_none_ignore_prepare_simulation @ Generate events, must not be called. <>= procedure :: generate_weighted_event => mci_none_generate_no_event procedure :: generate_unweighted_event => mci_none_generate_no_event <>= module subroutine mci_none_generate_no_event (mci, instance, sampler) class(mci_none_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler end subroutine mci_none_generate_no_event <>= module subroutine mci_none_generate_no_event (mci, instance, sampler) class(mci_none_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler call msg_fatal ("Integration: attempt to generate event " // & "with the 'mci_none' method") end subroutine mci_none_generate_no_event @ %def mci_none_generate_no_event @ Rebuild an event, no-op. <>= procedure :: rebuild_event => mci_none_rebuild_event <>= module subroutine mci_none_rebuild_event (mci, instance, sampler, state) class(mci_none_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state end subroutine mci_none_rebuild_event <>= module subroutine mci_none_rebuild_event (mci, instance, sampler, state) class(mci_none_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state end subroutine mci_none_rebuild_event @ %def mci_none_rebuild_event @ \subsection{Integrator instance} Covering the case of flat dimensions, we store a complete [[x]] array. This is filled when generating events. <>= public :: mci_none_instance_t <>= type, extends (mci_instance_t) :: mci_none_instance_t contains <> end type mci_none_instance_t @ %def mci_none_instance_t @ Output. <>= procedure :: write => mci_none_instance_write <>= module subroutine mci_none_instance_write (object, unit, pacify) class(mci_none_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify end subroutine mci_none_instance_write <>= module subroutine mci_none_instance_write (object, unit, pacify) class(mci_none_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Integrator instance: non-functional dummy" end subroutine mci_none_instance_write @ %def mci_none_instance_write @ The finalizer is empty. <>= procedure :: final => mci_none_instance_final <>= module subroutine mci_none_instance_final (object) class(mci_none_instance_t), intent(inout) :: object end subroutine mci_none_instance_final <>= module subroutine mci_none_instance_final (object) class(mci_none_instance_t), intent(inout) :: object end subroutine mci_none_instance_final @ %def mci_none_instance_final @ Initializer, empty. <>= procedure :: init => mci_none_instance_init <>= module subroutine mci_none_instance_init (mci_instance, mci) class(mci_none_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci end subroutine mci_none_instance_init <>= module subroutine mci_none_instance_init (mci_instance, mci) class(mci_none_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci end subroutine mci_none_instance_init @ %def mci_none_instance_init @ Copy the stored extrema of the integrand in the instance record. <>= procedure :: get_max => mci_none_instance_get_max <>= subroutine mci_none_instance_get_max (instance) class(mci_none_instance_t), intent(inout) :: instance associate (mci => instance%mci) if (mci%max_known) then instance%max_known = .true. instance%max = mci%max instance%min = mci%min instance%max_abs = mci%max_abs instance%min_abs = mci%min_abs end if end associate end subroutine mci_none_instance_get_max @ %def mci_none_instance_get_max @ Reverse operations: recall the extrema, but only if they are wider than the extrema already stored in the configuration. Also recalculate the efficiency value. <>= procedure :: set_max => mci_none_instance_set_max <>= subroutine mci_none_instance_set_max (instance) class(mci_none_instance_t), intent(inout) :: instance associate (mci => instance%mci) if (instance%max_known) then if (mci%max_known) then mci%max = max (mci%max, instance%max) mci%min = min (mci%min, instance%min) mci%max_abs = max (mci%max_abs, instance%max_abs) mci%min_abs = min (mci%min_abs, instance%min_abs) else mci%max = instance%max mci%min = instance%min mci%max_abs = instance%max_abs mci%min_abs = instance%min_abs mci%max_known = .true. end if if (mci%max_abs /= 0) then if (mci%integral_neg == 0) then mci%efficiency = mci%integral / mci%max_abs mci%efficiency_known = .true. else if (mci%n_calls /= 0) then mci%efficiency = & (mci%integral_pos - mci%integral_neg) / mci%max_abs mci%efficiency_known = .true. end if end if end if end associate end subroutine mci_none_instance_set_max @ %def mci_none_instance_set_max @ The weight cannot be computed. <>= procedure :: compute_weight => mci_none_instance_compute_weight <>= module subroutine mci_none_instance_compute_weight (mci, c) class(mci_none_instance_t), intent(inout) :: mci integer, intent(in) :: c end subroutine mci_none_instance_compute_weight <>= module subroutine mci_none_instance_compute_weight (mci, c) class(mci_none_instance_t), intent(inout) :: mci integer, intent(in) :: c call msg_fatal ("Integration: attempt to compute weight " // & "with the 'mci_none' method") end subroutine mci_none_instance_compute_weight @ %def mci_none_instance_compute_weight @ Record the integrand, no-op. <>= procedure :: record_integrand => mci_none_instance_record_integrand <>= module subroutine mci_none_instance_record_integrand (mci, integrand) class(mci_none_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand end subroutine mci_none_instance_record_integrand <>= module subroutine mci_none_instance_record_integrand (mci, integrand) class(mci_none_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand end subroutine mci_none_instance_record_integrand @ %def mci_none_instance_record_integrand @ No-op. <>= procedure :: init_simulation => mci_none_instance_init_simulation procedure :: final_simulation => mci_none_instance_final_simulation <>= module subroutine mci_none_instance_init_simulation & (instance, safety_factor) class(mci_none_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor end subroutine mci_none_instance_init_simulation module subroutine mci_none_instance_final_simulation (instance) class(mci_none_instance_t), intent(inout) :: instance end subroutine mci_none_instance_final_simulation <>= module subroutine mci_none_instance_init_simulation (instance, safety_factor) class(mci_none_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor end subroutine mci_none_instance_init_simulation module subroutine mci_none_instance_final_simulation (instance) class(mci_none_instance_t), intent(inout) :: instance end subroutine mci_none_instance_final_simulation @ %def mci_none_instance_init_simulation @ %def mci_none_instance_final_simulation @ Return excess weight for the current event: return zero, just in case. <>= procedure :: get_event_excess => mci_none_instance_get_event_excess <>= module function mci_none_instance_get_event_excess (mci) result (excess) class(mci_none_instance_t), intent(in) :: mci real(default) :: excess end function mci_none_instance_get_event_excess <>= module function mci_none_instance_get_event_excess (mci) result (excess) class(mci_none_instance_t), intent(in) :: mci real(default) :: excess excess = 0 end function mci_none_instance_get_event_excess @ %def mci_none_instance_get_event_excess @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[mci_none_ut.f90]]>>= <> module mci_none_ut use unit_tests use mci_none_uti <> <> contains <> end module mci_none_ut @ %def mci_none_ut @ <<[[mci_none_uti.f90]]>>= <> module mci_none_uti use mci_base use mci_none <> <> <> contains <> end module mci_none_uti @ %def mci_none_ut @ API: driver for the unit tests below. <>= public :: mci_none_test <>= subroutine mci_none_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine mci_none_test @ %def mci_none_test @ \subsubsection{Trivial sanity check} Construct an integrator and display it. <>= call test (mci_none_1, "mci_none_1", & "dummy integrator", & u, results) <>= public :: mci_none_1 <>= subroutine mci_none_1 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler write (u, "(A)") "* Test output: mci_none_1" write (u, "(A)") "* Purpose: display mci configuration" write (u, "(A)") write (u, "(A)") "* Allocate integrator" write (u, "(A)") allocate (mci_none_t :: mci) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) call mci_instance%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_none_1" end subroutine mci_none_1 @ %def mci_none_1 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Simple midpoint integration} This is a most simple implementation of an integrator. The algorithm is the straightforward multi-dimensional midpoint rule, i.e., the integration hypercube is binned uniformly, the integrand is evaluated at the midpoints of each bin, and the result is the average. The binning is equivalent for all integration dimensions. This rule is accurate to the order $h^2$, where $h$ is the bin width. Given that $h=N^{-1/d}$, where $d$ is the integration dimension and $N$ is the total number of sampling points, we get a relative error of order $N^{-2/d}$. This is superior to MC integration if $d<4$, and equivalent if $d=4$. It is not worse than higher-order formulas (such as Gauss integration) if the integrand is not smooth, e.g., if it contains cuts. The integrator is specifically single-channel. However, we do not limit the dimension. <<[[mci_midpoint.f90]]>>= <> module mci_midpoint <> use phs_base use mci_base <> <> <> interface <> end interface contains <> end module mci_midpoint @ %def mci_midpoint @ <<[[mci_midpoint_sub.f90]]>>= <> submodule (mci_midpoint) mci_midpoint_s use io_units use diagnostics implicit none contains <> end submodule mci_midpoint_s @ %def mci_midpoint_s @ \subsection{Integrator} The object contains the methods for integration and event generation. For the actual work and data storage, it spawns an instance object. After an integration pass, we update the [[max]] parameter to indicate the maximum absolute value of the integrand that the integrator encountered. This is required for event generation. <>= public :: mci_midpoint_t <>= type, extends (mci_t) :: mci_midpoint_t integer :: n_dim_binned = 0 logical, dimension(:), allocatable :: dim_is_binned logical :: calls_known = .false. integer :: n_calls = 0 integer :: n_calls_pos = 0 integer :: n_calls_nul = 0 integer :: n_calls_neg = 0 real(default) :: integral_pos = 0 real(default) :: integral_neg = 0 integer, dimension(:), allocatable :: n_bin logical :: max_known = .false. real(default) :: max = 0 real(default) :: min = 0 real(default) :: max_abs = 0 real(default) :: min_abs = 0 contains <> end type mci_midpoint_t @ %def mci_t @ Finalizer: base version is sufficient <>= procedure :: final => mci_midpoint_final <>= module subroutine mci_midpoint_final (object) class(mci_midpoint_t), intent(inout) :: object end subroutine mci_midpoint_final <>= module subroutine mci_midpoint_final (object) class(mci_midpoint_t), intent(inout) :: object call object%base_final () end subroutine mci_midpoint_final @ %def mci_midpoint_final @ Output. <>= procedure :: write => mci_midpoint_write <>= module subroutine mci_midpoint_write (object, unit, pacify, md5sum_version) class(mci_midpoint_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version end subroutine mci_midpoint_write <>= module subroutine mci_midpoint_write (object, unit, pacify, md5sum_version) class(mci_midpoint_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version integer :: u, i u = given_output_unit (unit) write (u, "(1x,A)") "Single-channel midpoint rule integrator:" call object%base_write (u, pacify, md5sum_version) if (object%n_dim_binned < object%n_dim) then write (u, "(3x,A,99(1x,I0))") "Flat dimensions =", & pack ([(i, i = 1, object%n_dim)], mask = .not. object%dim_is_binned) write (u, "(3x,A,I0)") "Number of binned dim = ", object%n_dim_binned end if if (object%calls_known) then write (u, "(3x,A,99(1x,I0))") "Number of bins =", object%n_bin write (u, "(3x,A,I0)") "Number of calls = ", object%n_calls if (object%n_calls_pos /= object%n_calls) then write (u, "(3x,A,I0)") " positive value = ", object%n_calls_pos write (u, "(3x,A,I0)") " zero value = ", object%n_calls_nul write (u, "(3x,A,I0)") " negative value = ", object%n_calls_neg write (u, "(3x,A,ES17.10)") & "Integral (pos. part) = ", object%integral_pos write (u, "(3x,A,ES17.10)") & "Integral (neg. part) = ", object%integral_neg end if end if if (object%max_known) then write (u, "(3x,A,ES17.10)") "Maximum of integrand = ", object%max write (u, "(3x,A,ES17.10)") "Minimum of integrand = ", object%min if (object%min /= object%min_abs) then write (u, "(3x,A,ES17.10)") "Maximum (abs. value) = ", object%max_abs write (u, "(3x,A,ES17.10)") "Minimum (abs. value) = ", object%min_abs end if end if if (allocated (object%rng)) call object%rng%write (u) end subroutine mci_midpoint_write @ %def mci_midpoint_write @ Startup message: short version. <>= procedure :: startup_message => mci_midpoint_startup_message <>= module subroutine mci_midpoint_startup_message (mci, unit, n_calls) class(mci_midpoint_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls end subroutine mci_midpoint_startup_message <>= module subroutine mci_midpoint_startup_message (mci, unit, n_calls) class(mci_midpoint_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls call mci%base_startup_message (unit = unit, n_calls = n_calls) if (mci%n_dim_binned < mci%n_dim) then write (msg_buffer, "(A,2(1x,I0,1x,A))") & "Integrator: Midpoint rule:", & mci%n_dim_binned, "binned dimensions" else write (msg_buffer, "(A,2(1x,I0,1x,A))") & "Integrator: Midpoint rule" end if call msg_message (unit = unit) end subroutine mci_midpoint_startup_message @ %def mci_midpoint_startup_message @ Log entry: just headline. <>= procedure :: write_log_entry => mci_midpoint_write_log_entry <>= module subroutine mci_midpoint_write_log_entry (mci, u) class(mci_midpoint_t), intent(in) :: mci integer, intent(in) :: u end subroutine mci_midpoint_write_log_entry <>= module subroutine mci_midpoint_write_log_entry (mci, u) class(mci_midpoint_t), intent(in) :: mci integer, intent(in) :: u write (u, "(1x,A)") "MC Integrator is Midpoint rule" end subroutine mci_midpoint_write_log_entry @ %def mci_midpoint_write_log_entry @ MD5 sum: nothing. <>= procedure :: compute_md5sum => mci_midpoint_compute_md5sum <>= module subroutine mci_midpoint_compute_md5sum (mci, pacify) class(mci_midpoint_t), intent(inout) :: mci logical, intent(in), optional :: pacify end subroutine mci_midpoint_compute_md5sum <>= module subroutine mci_midpoint_compute_md5sum (mci, pacify) class(mci_midpoint_t), intent(inout) :: mci logical, intent(in), optional :: pacify end subroutine mci_midpoint_compute_md5sum @ %def mci_midpoint_compute_md5sum @ The number of channels must be one. <>= procedure :: set_dimensions => mci_midpoint_set_dimensions <>= module subroutine mci_midpoint_set_dimensions (mci, n_dim, n_channel) class(mci_midpoint_t), intent(inout) :: mci integer, intent(in) :: n_dim integer, intent(in) :: n_channel end subroutine mci_midpoint_set_dimensions <>= module subroutine mci_midpoint_set_dimensions (mci, n_dim, n_channel) class(mci_midpoint_t), intent(inout) :: mci integer, intent(in) :: n_dim integer, intent(in) :: n_channel if (n_channel == 1) then mci%n_channel = n_channel mci%n_dim = n_dim allocate (mci%dim_is_binned (mci%n_dim)) mci%dim_is_binned = .true. mci%n_dim_binned = count (mci%dim_is_binned) allocate (mci%n_bin (mci%n_dim)) mci%n_bin = 0 else call msg_fatal ("Attempt to initialize single-channel integrator & &for multiple channels") end if end subroutine mci_midpoint_set_dimensions @ %def mci_midpoint_set_dimensions @ Declare particular dimensions as flat. These dimensions will not be binned. <>= procedure :: declare_flat_dimensions => mci_midpoint_declare_flat_dimensions <>= module subroutine mci_midpoint_declare_flat_dimensions (mci, dim_flat) class(mci_midpoint_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat end subroutine mci_midpoint_declare_flat_dimensions <>= module subroutine mci_midpoint_declare_flat_dimensions (mci, dim_flat) class(mci_midpoint_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat integer :: d mci%n_dim_binned = mci%n_dim - size (dim_flat) do d = 1, size (dim_flat) mci%dim_is_binned(dim_flat(d)) = .false. end do mci%n_dim_binned = count (mci%dim_is_binned) end subroutine mci_midpoint_declare_flat_dimensions @ %def mci_midpoint_declare_flat_dimensions @ Declare particular channels as equivalent. This has no effect. <>= procedure :: declare_equivalences => mci_midpoint_ignore_equivalences <>= module subroutine mci_midpoint_ignore_equivalences & (mci, channel, dim_offset) class(mci_midpoint_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset end subroutine mci_midpoint_ignore_equivalences <>= module subroutine mci_midpoint_ignore_equivalences (mci, channel, dim_offset) class(mci_midpoint_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset end subroutine mci_midpoint_ignore_equivalences @ %def mci_midpoint_ignore_equivalences @ Allocate instance with matching type. Gfortran 7/8/9 bug, has to remain in the main module: <>= procedure :: allocate_instance => mci_midpoint_allocate_instance <>= subroutine mci_midpoint_allocate_instance (mci, mci_instance) class(mci_midpoint_t), intent(in) :: mci class(mci_instance_t), intent(out), pointer :: mci_instance allocate (mci_midpoint_instance_t :: mci_instance) end subroutine mci_midpoint_allocate_instance @ %def mci_midpoint_allocate_instance @ Integrate. The number of dimensions is arbitrary. We make sure that the number of calls is evenly distributed among the dimensions. The actual number of calls will typically be smaller than the requested number, but never smaller than 1. The sampling over a variable number of dimensions implies a variable number of nested loops. We implement this by a recursive subroutine, one loop in each recursion level. The number of iterations [[n_it]] is ignored. Also, the error is set to zero in the current implementation. With this integrator, we allow the calculation to abort immediately when forced by a signal. There is no state that we can save, hence we do not catch an interrupt. <>= procedure :: integrate => mci_midpoint_integrate <>= module subroutine mci_midpoint_integrate (mci, instance, sampler, n_it, & n_calls, results, pacify) class(mci_midpoint_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: pacify class(mci_results_t), intent(inout), optional :: results end subroutine mci_midpoint_integrate <>= module subroutine mci_midpoint_integrate (mci, instance, sampler, n_it, & n_calls, results, pacify) class(mci_midpoint_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: pacify class(mci_results_t), intent(inout), optional :: results real(default), dimension(:), allocatable :: x real(default) :: integral, integral_pos, integral_neg integer :: n_bin select type (instance) type is (mci_midpoint_instance_t) allocate (x (mci%n_dim)) integral = 0 integral_pos = 0 integral_neg = 0 select case (mci%n_dim_binned) case (1) n_bin = n_calls case (2:) n_bin = max (int (n_calls ** (1. / mci%n_dim_binned)), 1) end select where (mci%dim_is_binned) mci%n_bin = n_bin elsewhere mci%n_bin = 1 end where mci%n_calls = product (mci%n_bin) mci%n_calls_pos = 0 mci%n_calls_nul = 0 mci%n_calls_neg = 0 mci%calls_known = .true. call sample_dim (mci%n_dim) mci%integral = integral / mci%n_calls mci%integral_pos = integral_pos / mci%n_calls mci%integral_neg = integral_neg / mci%n_calls mci%integral_known = .true. call instance%set_max () if (present (results)) then call results%record (1, mci%n_calls, & mci%integral, mci%error, mci%efficiency) end if end select contains recursive subroutine sample_dim (d) integer, intent(in) :: d integer :: i real(default) :: value do i = 1, mci%n_bin(d) x(d) = (i - 0.5_default) / mci%n_bin(d) if (d > 1) then call sample_dim (d - 1) else if (signal_is_pending ()) return call instance%evaluate (sampler, 1, x) value = instance%get_value () if (value > 0) then mci%n_calls_pos = mci%n_calls_pos + 1 integral = integral + value integral_pos = integral_pos + value else if (value == 0) then mci%n_calls_nul = mci%n_calls_nul + 1 else mci%n_calls_neg = mci%n_calls_neg + 1 integral = integral + value integral_neg = integral_neg + value end if end if end do end subroutine sample_dim end subroutine mci_midpoint_integrate @ %def mci_midpoint_integrate @ Simulation initializer and finalizer: nothing to do here. <>= procedure :: prepare_simulation => mci_midpoint_ignore_prepare_simulation <>= module subroutine mci_midpoint_ignore_prepare_simulation (mci) class(mci_midpoint_t), intent(inout) :: mci end subroutine mci_midpoint_ignore_prepare_simulation <>= module subroutine mci_midpoint_ignore_prepare_simulation (mci) class(mci_midpoint_t), intent(inout) :: mci end subroutine mci_midpoint_ignore_prepare_simulation @ %def mci_midpoint_ignore_prepare_simulation @ Generate weighted event. <>= procedure :: generate_weighted_event => mci_midpoint_generate_weighted_event <>= module subroutine mci_midpoint_generate_weighted_event & (mci, instance, sampler) class(mci_midpoint_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler end subroutine mci_midpoint_generate_weighted_event <>= module subroutine mci_midpoint_generate_weighted_event & (mci, instance, sampler) class(mci_midpoint_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler real(default), dimension(mci%n_dim) :: x select type (instance) type is (mci_midpoint_instance_t) call mci%rng%generate (x) call instance%evaluate (sampler, 1, x) instance%excess_weight = 0 end select end subroutine mci_midpoint_generate_weighted_event @ %def mci_midpoint_generate_weighted_event @ For unweighted events, we generate weighted events and apply a simple rejection step to the relative event weight, until an event passes. Note that we use the [[max_abs]] value stored in the configuration record, not the one stored in the instance. The latter may change during event generation. After an event generation pass is over, we may update the value for a subsequent pass. <>= procedure :: generate_unweighted_event => & mci_midpoint_generate_unweighted_event <>= module subroutine mci_midpoint_generate_unweighted_event & (mci, instance, sampler) class(mci_midpoint_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler end subroutine mci_midpoint_generate_unweighted_event <>= module subroutine mci_midpoint_generate_unweighted_event & (mci, instance, sampler) class(mci_midpoint_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler real(default) :: x, norm, int select type (instance) type is (mci_midpoint_instance_t) if (mci%max_known .and. mci%max_abs > 0) then norm = abs (mci%max_abs * instance%safety_factor) REJECTION: do call mci%generate_weighted_event (instance, sampler) if (sampler%is_valid ()) then call mci%rng%generate (x) int = abs (instance%integrand) if (x * norm <= int) then if (norm > 0 .and. norm < int) then instance%excess_weight = int / norm - 1 end if exit REJECTION end if end if if (signal_is_pending ()) return end do REJECTION else call msg_fatal ("Unweighted event generation: & &maximum of integrand is zero or unknown") end if end select end subroutine mci_midpoint_generate_unweighted_event @ %def mci_midpoint_generate_unweighted_event @ Rebuild an event, using the [[state]] input. <>= procedure :: rebuild_event => mci_midpoint_rebuild_event <>= module subroutine mci_midpoint_rebuild_event (mci, instance, sampler, state) class(mci_midpoint_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state end subroutine mci_midpoint_rebuild_event <>= module subroutine mci_midpoint_rebuild_event (mci, instance, sampler, state) class(mci_midpoint_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state select type (instance) type is (mci_midpoint_instance_t) call instance%recall (sampler, state) end select end subroutine mci_midpoint_rebuild_event @ %def mci_midpoint_rebuild_event @ \subsection{Integrator instance} Covering the case of flat dimensions, we store a complete [[x]] array. This is filled when generating events. <>= public :: mci_midpoint_instance_t <>= type, extends (mci_instance_t) :: mci_midpoint_instance_t type(mci_midpoint_t), pointer :: mci => null () logical :: max_known = .false. real(default) :: max = 0 real(default) :: min = 0 real(default) :: max_abs = 0 real(default) :: min_abs = 0 real(default) :: safety_factor = 1 real(default) :: excess_weight = 0 contains <> end type mci_midpoint_instance_t @ %def mci_midpoint_instance_t @ Output. <>= procedure :: write => mci_midpoint_instance_write <>= module subroutine mci_midpoint_instance_write (object, unit, pacify) class(mci_midpoint_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify end subroutine mci_midpoint_instance_write <>= module subroutine mci_midpoint_instance_write (object, unit, pacify) class(mci_midpoint_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify integer :: u u = given_output_unit (unit) write (u, "(1x,A,9(1x,F12.10))") "x =", object%x(:,1) write (u, "(1x,A,ES19.12)") "Integrand = ", object%integrand write (u, "(1x,A,ES19.12)") "Weight = ", object%mci_weight if (object%safety_factor /= 1) then write (u, "(1x,A,ES19.12)") "Safety f = ", object%safety_factor end if if (object%excess_weight /= 0) then write (u, "(1x,A,ES19.12)") "Excess = ", object%excess_weight end if if (object%max_known) then write (u, "(1x,A,ES19.12)") "Maximum = ", object%max write (u, "(1x,A,ES19.12)") "Minimum = ", object%min if (object%min /= object%min_abs) then write (u, "(1x,A,ES19.12)") "Max.(abs) = ", object%max_abs write (u, "(1x,A,ES19.12)") "Min.(abs) = ", object%min_abs end if end if end subroutine mci_midpoint_instance_write @ %def mci_midpoint_instance_write @ The finalizer is empty. <>= procedure :: final => mci_midpoint_instance_final <>= module subroutine mci_midpoint_instance_final (object) class(mci_midpoint_instance_t), intent(inout) :: object end subroutine mci_midpoint_instance_final <>= module subroutine mci_midpoint_instance_final (object) class(mci_midpoint_instance_t), intent(inout) :: object end subroutine mci_midpoint_instance_final @ %def mci_midpoint_instance_final @ Initializer. <>= procedure :: init => mci_midpoint_instance_init <>= module subroutine mci_midpoint_instance_init (mci_instance, mci) class(mci_midpoint_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci end subroutine mci_midpoint_instance_init <>= module subroutine mci_midpoint_instance_init (mci_instance, mci) class(mci_midpoint_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci call mci_instance%base_init (mci) select type (mci) type is (mci_midpoint_t) mci_instance%mci => mci call mci_instance%get_max () mci_instance%selected_channel = 1 end select end subroutine mci_midpoint_instance_init @ %def mci_midpoint_instance_init @ Copy the stored extrema of the integrand in the instance record. <>= procedure :: get_max => mci_midpoint_instance_get_max <>= module subroutine mci_midpoint_instance_get_max (instance) class(mci_midpoint_instance_t), intent(inout) :: instance end subroutine mci_midpoint_instance_get_max <>= module subroutine mci_midpoint_instance_get_max (instance) class(mci_midpoint_instance_t), intent(inout) :: instance associate (mci => instance%mci) if (mci%max_known) then instance%max_known = .true. instance%max = mci%max instance%min = mci%min instance%max_abs = mci%max_abs instance%min_abs = mci%min_abs end if end associate end subroutine mci_midpoint_instance_get_max @ %def mci_midpoint_instance_get_max @ Reverse operations: recall the extrema, but only if they are wider than the extrema already stored in the configuration. Also recalculate the efficiency value. <>= procedure :: set_max => mci_midpoint_instance_set_max <>= module subroutine mci_midpoint_instance_set_max (instance) class(mci_midpoint_instance_t), intent(inout) :: instance end subroutine mci_midpoint_instance_set_max <>= module subroutine mci_midpoint_instance_set_max (instance) class(mci_midpoint_instance_t), intent(inout) :: instance associate (mci => instance%mci) if (instance%max_known) then if (mci%max_known) then mci%max = max (mci%max, instance%max) mci%min = min (mci%min, instance%min) mci%max_abs = max (mci%max_abs, instance%max_abs) mci%min_abs = min (mci%min_abs, instance%min_abs) else mci%max = instance%max mci%min = instance%min mci%max_abs = instance%max_abs mci%min_abs = instance%min_abs mci%max_known = .true. end if if (mci%max_abs /= 0) then if (mci%integral_neg == 0) then mci%efficiency = mci%integral / mci%max_abs mci%efficiency_known = .true. else if (mci%n_calls /= 0) then mci%efficiency = & (mci%integral_pos - mci%integral_neg) / mci%max_abs mci%efficiency_known = .true. end if end if end if end associate end subroutine mci_midpoint_instance_set_max @ %def mci_midpoint_instance_set_max @ The weight is the Jacobian of the mapping for the only channel. <>= procedure :: compute_weight => mci_midpoint_instance_compute_weight <>= module subroutine mci_midpoint_instance_compute_weight (mci, c) class(mci_midpoint_instance_t), intent(inout) :: mci integer, intent(in) :: c end subroutine mci_midpoint_instance_compute_weight <>= module subroutine mci_midpoint_instance_compute_weight (mci, c) class(mci_midpoint_instance_t), intent(inout) :: mci integer, intent(in) :: c select case (c) case (1) mci%mci_weight = mci%f(1) case default call msg_fatal ("MCI midpoint integrator: only single channel supported") end select end subroutine mci_midpoint_instance_compute_weight @ %def mci_midpoint_instance_compute_weight @ Record the integrand. Update stored values for maximum and minimum. <>= procedure :: record_integrand => mci_midpoint_instance_record_integrand <>= module subroutine mci_midpoint_instance_record_integrand (mci, integrand) class(mci_midpoint_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand end subroutine mci_midpoint_instance_record_integrand <>= module subroutine mci_midpoint_instance_record_integrand (mci, integrand) class(mci_midpoint_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand mci%integrand = integrand if (mci%max_known) then mci%max = max (mci%max, integrand) mci%min = min (mci%min, integrand) mci%max_abs = max (mci%max_abs, abs (integrand)) mci%min_abs = min (mci%min_abs, abs (integrand)) else mci%max = integrand mci%min = integrand mci%max_abs = abs (integrand) mci%min_abs = abs (integrand) mci%max_known = .true. end if end subroutine mci_midpoint_instance_record_integrand @ %def mci_midpoint_instance_record_integrand @ We store the safety factor, otherwise nothing to do here. <>= procedure :: init_simulation => mci_midpoint_instance_init_simulation procedure :: final_simulation => mci_midpoint_instance_final_simulation <>= module subroutine mci_midpoint_instance_init_simulation & (instance, safety_factor) class(mci_midpoint_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor end subroutine mci_midpoint_instance_init_simulation module subroutine mci_midpoint_instance_final_simulation (instance) class(mci_midpoint_instance_t), intent(inout) :: instance end subroutine mci_midpoint_instance_final_simulation <>= module subroutine mci_midpoint_instance_init_simulation & (instance, safety_factor) class(mci_midpoint_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor if (present (safety_factor)) instance%safety_factor = safety_factor end subroutine mci_midpoint_instance_init_simulation module subroutine mci_midpoint_instance_final_simulation (instance) class(mci_midpoint_instance_t), intent(inout) :: instance end subroutine mci_midpoint_instance_final_simulation @ %def mci_midpoint_instance_init_simulation @ %def mci_midpoint_instance_final_simulation @ Return excess weight for the current event. <>= procedure :: get_event_excess => mci_midpoint_instance_get_event_excess <>= module function mci_midpoint_instance_get_event_excess (mci) result (excess) class(mci_midpoint_instance_t), intent(in) :: mci real(default) :: excess end function mci_midpoint_instance_get_event_excess <>= module function mci_midpoint_instance_get_event_excess (mci) result (excess) class(mci_midpoint_instance_t), intent(in) :: mci real(default) :: excess excess = mci%excess_weight end function mci_midpoint_instance_get_event_excess @ %def mci_midpoint_instance_get_event_excess @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[mci_midpoint_ut.f90]]>>= <> module mci_midpoint_ut use unit_tests use mci_midpoint_uti <> <> contains <> end module mci_midpoint_ut @ %def mci_midpoint_ut @ <<[[mci_midpoint_uti.f90]]>>= <> module mci_midpoint_uti <> use io_units use rng_base use mci_base use mci_midpoint use rng_base_ut, only: rng_test_t <> <> <> contains <> end module mci_midpoint_uti @ %def mci_midpoint_ut @ API: driver for the unit tests below. <>= public :: mci_midpoint_test <>= subroutine mci_midpoint_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine mci_midpoint_test @ %def mci_midpoint_test @ \subsubsection{Test sampler} A test sampler object should implement a function with known integral that we can use to check the integrator. This is the function $f(x) = 3 x^2$ with integral $\int_0^1 f(x)\,dx=1$ and maximum $f(1)=3$. If the integration dimension is greater than one, the function is extended as a constant in the other dimension(s). Mimicking the behavior of a process object, we store the argument and result inside the sampler, so we can [[fetch]] results. <>= type, extends (mci_sampler_t) :: test_sampler_1_t real(default), dimension(:), allocatable :: x real(default) :: val contains <> end type test_sampler_1_t @ %def test_sampler_1_t @ Output: There is nothing stored inside, so just print an informative line. <>= procedure :: write => test_sampler_1_write <>= subroutine test_sampler_1_write (object, unit, testflag) class(test_sampler_1_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Test sampler: f(x) = 3 x^2" end subroutine test_sampler_1_write @ %def test_sampler_1_write @ Evaluation: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure :: evaluate => test_sampler_1_evaluate <>= subroutine test_sampler_1_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_1_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f if (allocated (sampler%x)) deallocate (sampler%x) allocate (sampler%x (size (x_in))) sampler%x = x_in sampler%val = 3 * x_in(1) ** 2 call sampler%fetch (val, x, f) end subroutine test_sampler_1_evaluate @ %def test_sampler_1_evaluate @ The point is always valid. <>= procedure :: is_valid => test_sampler_1_is_valid <>= function test_sampler_1_is_valid (sampler) result (valid) class(test_sampler_1_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_1_is_valid @ %def test_sampler_1_is_valid @ Rebuild: compute all but the function value. <>= procedure :: rebuild => test_sampler_1_rebuild <>= subroutine test_sampler_1_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_1_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f if (allocated (sampler%x)) deallocate (sampler%x) allocate (sampler%x (size (x_in))) sampler%x = x_in sampler%val = val x(:,1) = sampler%x f = 1 end subroutine test_sampler_1_rebuild @ %def test_sampler_1_rebuild @ Extract the results. <>= procedure :: fetch => test_sampler_1_fetch <>= subroutine test_sampler_1_fetch (sampler, val, x, f) class(test_sampler_1_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x(:,1) = sampler%x f = 1 end subroutine test_sampler_1_fetch @ %def test_sampler_1_fetch @ This is the function $f(x) = 3 x^2 + 2 y$ with integral $\int_0^1 f(x,y)\,dx\,dy=2$ and maximum $f(1)=5$. <>= type, extends (mci_sampler_t) :: test_sampler_2_t real(default) :: val real(default), dimension(2) :: x contains <> end type test_sampler_2_t @ %def test_sampler_2_t @ Output: There is nothing stored inside, so just print an informative line. <>= procedure :: write => test_sampler_2_write <>= subroutine test_sampler_2_write (object, unit, testflag) class(test_sampler_2_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Test sampler: f(x) = 3 x^2 + 2 y" end subroutine test_sampler_2_write @ %def test_sampler_2_write @ Evaluate: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure :: evaluate => test_sampler_2_evaluate <>= subroutine test_sampler_2_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f sampler%x = x_in sampler%val = 3 * x_in(1) ** 2 + 2 * x_in(2) call sampler%fetch (val, x, f) end subroutine test_sampler_2_evaluate @ %def test_sampler_2_evaluate @ The point is always valid. <>= procedure :: is_valid => test_sampler_2_is_valid <>= function test_sampler_2_is_valid (sampler) result (valid) class(test_sampler_2_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_2_is_valid @ %def test_sampler_2_is_valid @ Rebuild: compute all but the function value. <>= procedure :: rebuild => test_sampler_2_rebuild <>= subroutine test_sampler_2_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f sampler%x = x_in sampler%val = val x(:,1) = sampler%x f = 1 end subroutine test_sampler_2_rebuild @ %def test_sampler_2_rebuild <>= procedure :: fetch => test_sampler_2_fetch <>= subroutine test_sampler_2_fetch (sampler, val, x, f) class(test_sampler_2_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x(:,1) = sampler%x f = 1 end subroutine test_sampler_2_fetch @ %def test_sampler_2_fetch @ This is the function $f(x) = (1 - 3 x^2)\,\theta(x-1/2)$ with integral $\int_0^1 f(x)\,dx=-3/8$, minimum $f(1)=-2$ and maximum $f(1/2)=1/4$. If the integration dimension is greater than one, the function is extended as a constant in the other dimension(s). <>= type, extends (mci_sampler_t) :: test_sampler_4_t real(default) :: val real(default), dimension(:), allocatable :: x contains <> end type test_sampler_4_t @ %def test_sampler_4_t @ Output: There is nothing stored inside, so just print an informative line. <>= procedure :: write => test_sampler_4_write <>= subroutine test_sampler_4_write (object, unit, testflag) class(test_sampler_4_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Test sampler: f(x) = 1 - 3 x^2" end subroutine test_sampler_4_write @ %def test_sampler_4_write @ Evaluation: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure :: evaluate => test_sampler_4_evaluate <>= subroutine test_sampler_4_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_4_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f if (x_in(1) >= .5_default) then sampler%val = 1 - 3 * x_in(1) ** 2 else sampler%val = 0 end if if (.not. allocated (sampler%x)) allocate (sampler%x (size (x_in))) sampler%x = x_in call sampler%fetch (val, x, f) end subroutine test_sampler_4_evaluate @ %def test_sampler_4_evaluate @ The point is always valid. <>= procedure :: is_valid => test_sampler_4_is_valid <>= function test_sampler_4_is_valid (sampler) result (valid) class(test_sampler_4_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_4_is_valid @ %def test_sampler_4_is_valid @ Rebuild: compute all but the function value. <>= procedure :: rebuild => test_sampler_4_rebuild <>= subroutine test_sampler_4_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_4_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f sampler%x = x_in sampler%val = val x(:,1) = sampler%x f = 1 end subroutine test_sampler_4_rebuild @ %def test_sampler_4_rebuild <>= procedure :: fetch => test_sampler_4_fetch <>= subroutine test_sampler_4_fetch (sampler, val, x, f) class(test_sampler_4_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x(:,1) = sampler%x f = 1 end subroutine test_sampler_4_fetch @ %def test_sampler_4_fetch @ \subsubsection{One-dimensional integration} Construct an integrator and use it for a one-dimensional sampler. <>= call test (mci_midpoint_1, "mci_midpoint_1", & "one-dimensional integral", & u, results) <>= public :: mci_midpoint_1 <>= subroutine mci_midpoint_1 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler write (u, "(A)") "* Test output: mci_midpoint_1" write (u, "(A)") "* Purpose: integrate function in one dimension" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_midpoint_t :: mci) call mci%set_dimensions (1, 1) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_1_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for x = 0.8" write (u, "(A)") call mci_instance%evaluate (sampler, 1, [0.8_default]) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for x = 0.7" write (u, "(A)") call mci_instance%evaluate (sampler, 1, [0.7_default]) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for x = 0.9" write (u, "(A)") call mci_instance%evaluate (sampler, 1, [0.9_default]) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_calls = 1000" write (u, "(A)") call mci%integrate (mci_instance, sampler, 1, 1000) call mci%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_midpoint_1" end subroutine mci_midpoint_1 @ %def mci_midpoint_1 @ \subsubsection{Two-dimensional integration} Construct an integrator and use it for a two-dimensional sampler. <>= call test (mci_midpoint_2, "mci_midpoint_2", & "two-dimensional integral", & u, results) <>= public :: mci_midpoint_2 <>= subroutine mci_midpoint_2 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler write (u, "(A)") "* Test output: mci_midpoint_2" write (u, "(A)") "* Purpose: integrate function in two dimensions" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_midpoint_t :: mci) call mci%set_dimensions (2, 1) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_2_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for x = 0.8, y = 0.2" write (u, "(A)") call mci_instance%evaluate (sampler, 1, [0.8_default, 0.2_default]) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_calls = 1000" write (u, "(A)") call mci%integrate (mci_instance, sampler, 1, 1000) call mci%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_midpoint_2" end subroutine mci_midpoint_2 @ %def mci_midpoint_2 @ \subsubsection{Two-dimensional integration with flat dimension} Construct an integrator and use it for a two-dimensional sampler, where the function is constant in the second dimension. <>= call test (mci_midpoint_3, "mci_midpoint_3", & "two-dimensional integral with flat dimension", & u, results) <>= public :: mci_midpoint_3 <>= subroutine mci_midpoint_3 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler write (u, "(A)") "* Test output: mci_midpoint_3" write (u, "(A)") "* Purpose: integrate function with one flat dimension" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_midpoint_t :: mci) select type (mci) type is (mci_midpoint_t) call mci%set_dimensions (2, 1) call mci%declare_flat_dimensions ([2]) end select call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_1_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for x = 0.8, y = 0.2" write (u, "(A)") call mci_instance%evaluate (sampler, 1, [0.8_default, 0.2_default]) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_calls = 1000" write (u, "(A)") call mci%integrate (mci_instance, sampler, 1, 1000) call mci%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_midpoint_3" end subroutine mci_midpoint_3 @ %def mci_midpoint_3 @ \subsubsection{Integrand with sign flip} Construct an integrator and use it for a one-dimensional sampler. <>= call test (mci_midpoint_4, "mci_midpoint_4", & "integrand with sign flip", & u, results) <>= public :: mci_midpoint_4 <>= subroutine mci_midpoint_4 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler write (u, "(A)") "* Test output: mci_midpoint_4" write (u, "(A)") "* Purpose: integrate function with sign flip & &in one dimension" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_midpoint_t :: mci) call mci%set_dimensions (1, 1) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_4_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for x = 0.8" write (u, "(A)") call mci_instance%evaluate (sampler, 1, [0.8_default]) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_calls = 1000" write (u, "(A)") call mci%integrate (mci_instance, sampler, 1, 1000) call mci%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_midpoint_4" end subroutine mci_midpoint_4 @ %def mci_midpoint_4 @ \subsubsection{Weighted events} Generate weighted events. Without rejection, we do not need to know maxima and minima, so we can start generating events immediately. We have two dimensions. <>= call test (mci_midpoint_5, "mci_midpoint_5", & "weighted events", & u, results) <>= public :: mci_midpoint_5 <>= subroutine mci_midpoint_5 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng class(mci_state_t), allocatable :: state write (u, "(A)") "* Test output: mci_midpoint_5" write (u, "(A)") "* Purpose: generate weighted events" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_midpoint_t :: mci) call mci%set_dimensions (2, 1) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_2_t :: sampler) write (u, "(A)") "* Initialize random-number generator" write (u, "(A)") allocate (rng_test_t :: rng) call rng%init () call mci%import_rng (rng) write (u, "(A)") "* Generate weighted event" write (u, "(A)") call mci%generate_weighted_event (mci_instance, sampler) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Generate weighted event" write (u, "(A)") call mci%generate_weighted_event (mci_instance, sampler) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Store data" write (u, "(A)") allocate (state) call mci_instance%store (state) call mci_instance%final () deallocate (mci_instance) call state%write (u) write (u, "(A)") write (u, "(A)") "* Recall data and rebuild event" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) call mci%rebuild_event (mci_instance, sampler, state) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () deallocate (mci_instance) call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_midpoint_5" end subroutine mci_midpoint_5 @ %def mci_midpoint_5 @ \subsubsection{Unweighted events} Generate unweighted events. The integrand has a sign flip in it. <>= call test (mci_midpoint_6, "mci_midpoint_6", & "unweighted events", & u, results) <>= public :: mci_midpoint_6 <>= subroutine mci_midpoint_6 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_midpoint_6" write (u, "(A)") "* Purpose: generate unweighted events" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_midpoint_t :: mci) call mci%set_dimensions (1, 1) write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_4_t :: sampler) write (u, "(A)") "* Initialize random-number generator" write (u, "(A)") allocate (rng_test_t :: rng) call rng%init () call mci%import_rng (rng) write (u, "(A)") "* Integrate (determine maximum of integrand" write (u, "(A)") call mci%integrate (mci_instance, sampler, 1, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Generate unweighted event" write (u, "(A)") call mci%generate_unweighted_event (mci_instance, sampler) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () deallocate (mci_instance) call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_midpoint_6" end subroutine mci_midpoint_6 @ %def mci_midpoint_6 @ \subsubsection{Excess weight} Generate unweighted events. With only 2 points for integration, the maximum of the integrand is too low, and we produce excess weight. <>= call test (mci_midpoint_7, "mci_midpoint_7", & "excess weight", & u, results) <>= public :: mci_midpoint_7 <>= subroutine mci_midpoint_7 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_midpoint_7" write (u, "(A)") "* Purpose: generate unweighted event & &with excess weight" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_midpoint_t :: mci) call mci%set_dimensions (1, 1) write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_4_t :: sampler) write (u, "(A)") "* Initialize random-number generator" write (u, "(A)") allocate (rng_test_t :: rng) call rng%init () call mci%import_rng (rng) write (u, "(A)") "* Integrate (determine maximum of integrand" write (u, "(A)") call mci%integrate (mci_instance, sampler, 1, 2) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Generate unweighted event" write (u, "(A)") call mci_instance%init_simulation () call mci%generate_unweighted_event (mci_instance, sampler) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Use getter methods" write (u, "(A)") write (u, "(1x,A,1x,ES19.12)") "weight =", mci_instance%get_event_weight () write (u, "(1x,A,1x,ES19.12)") "excess =", mci_instance%get_event_excess () write (u, "(A)") write (u, "(A)") "* Apply safety factor" write (u, "(A)") call mci_instance%init_simulation (safety_factor = 2.1_default) write (u, "(A)") "* Generate unweighted event" write (u, "(A)") call mci%generate_unweighted_event (mci_instance, sampler) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Use getter methods" write (u, "(A)") write (u, "(1x,A,1x,ES19.12)") "weight =", mci_instance%get_event_weight () write (u, "(1x,A,1x,ES19.12)") "excess =", mci_instance%get_event_excess () write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () deallocate (mci_instance) call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_midpoint_7" end subroutine mci_midpoint_7 @ %def mci_midpoint_7 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{\vamp\ interface} The standard method for integration is \vamp: the multi-channel version of the VEGAS algorithm. Each parameterization (channel) of the hypercube is binned in each dimension. The binning is equally equidistant, but an iteration of the integration procedure, the binning is updated for each dimension, according to the variance distribution of the integrand, summed over all other dimension. In the next iteration, the binning approximates (hopefully) follows the integrand more closely, and the accuracy of the result is increased. Furthermore, the relative weight of the individual channels is also updated after an iteration. The bin distribution is denoted as the grid for a channel, which we can write to file and reuse later. In our implementation we specify the generic \vamp\ algorithm more tightly: the number of bins is equal for all dimensions, the initial weights are all equal. The user controls whether to update bins and/or weights after each iteration. The integration is organized in passes, each one consisting of several iterations with a common number of calls to the integrand. The first passes are intended as warmup, so the results are displayed but otherwise discarded. In the final pass, the integration estimates for the individual iterations are averaged for the final result. <<[[mci_vamp.f90]]>>= <> module mci_vamp <> <> use diagnostics use phs_base use rng_base use rng_tao use vamp !NODEP! use exceptions !NODEP! use mci_base <> <> <> <> interface <> end interface contains <> end module mci_vamp @ %def mci_vamp @ <<[[mci_vamp_sub.f90]]>>= <> submodule (mci_vamp) mci_vamp_s use io_units use constants, only: zero use format_utils, only: pac_fmt use format_utils, only: write_separator use format_defs, only: FMT_12, FMT_14, FMT_17, FMT_19 use md5 implicit none contains <> end submodule mci_vamp_s @ %def mci_vamp_s @ \subsection{Grid parameters} This is a transparent container. It holds the parameters that are stored in grid files, and are checked when grid files are read. <>= public :: grid_parameters_t <>= type :: grid_parameters_t integer :: threshold_calls = 0 integer :: min_calls_per_channel = 10 integer :: min_calls_per_bin = 10 integer :: min_bins = 3 integer :: max_bins = 20 logical :: stratified = .true. logical :: use_vamp_equivalences = .true. real(default) :: channel_weights_power = 0.25_default real(default) :: accuracy_goal = 0 real(default) :: error_goal = 0 real(default) :: rel_error_goal = 0 contains <> end type grid_parameters_t @ %def grid_parameters_t @ I/O: <>= procedure :: write => grid_parameters_write <>= module subroutine grid_parameters_write (object, unit) class(grid_parameters_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine grid_parameters_write <>= module subroutine grid_parameters_write (object, unit) class(grid_parameters_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A,I0)") "threshold_calls = ", & object%threshold_calls write (u, "(3x,A,I0)") "min_calls_per_channel = ", & object%min_calls_per_channel write (u, "(3x,A,I0)") "min_calls_per_bin = ", & object%min_calls_per_bin write (u, "(3x,A,I0)") "min_bins = ", & object%min_bins write (u, "(3x,A,I0)") "max_bins = ", & object%max_bins write (u, "(3x,A,L1)") "stratified = ", & object%stratified write (u, "(3x,A,L1)") "use_vamp_equivalences = ", & object%use_vamp_equivalences write (u, "(3x,A,F10.7)") "channel_weights_power = ", & object%channel_weights_power if (object%accuracy_goal > 0) then write (u, "(3x,A,F10.7)") "accuracy_goal = ", & object%accuracy_goal end if if (object%error_goal > 0) then write (u, "(3x,A,F10.7)") "error_goal = ", & object%error_goal end if if (object%rel_error_goal > 0) then write (u, "(3x,A,F10.7)") "rel_error_goal = ", & object%rel_error_goal end if end subroutine grid_parameters_write @ %def grid_parameters_write @ \subsection{History parameters} The history parameters are also stored in a transparent container. This is not a part of the grid definition, and should not be included in the MD5 sum. <>= public :: history_parameters_t <>= type :: history_parameters_t logical :: global = .true. logical :: global_verbose = .false. logical :: channel = .false. logical :: channel_verbose = .false. contains <> end type history_parameters_t @ %def history_parameters_t @ I/O: <>= procedure :: write => history_parameters_write <>= module subroutine history_parameters_write (object, unit) class(history_parameters_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine history_parameters_write <>= module subroutine history_parameters_write (object, unit) class(history_parameters_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A,L1)") "history(global) = ", object%global write (u, "(3x,A,L1)") "history(global) verb. = ", object%global_verbose write (u, "(3x,A,L1)") "history(channels) = ", object%channel write (u, "(3x,A,L1)") "history(chann.) verb. = ", object%channel_verbose end subroutine history_parameters_write @ %def history_parameters_write @ \subsection{Integration pass} We store the parameters for each integration pass in a linked list. <>= type :: pass_t integer :: i_pass = 0 integer :: i_first_it = 0 integer :: n_it = 0 integer :: n_calls = 0 integer :: n_bins = 0 logical :: adapt_grids = .false. logical :: adapt_weights = .false. logical :: is_final_pass = .false. logical :: integral_defined = .false. integer, dimension(:), allocatable :: calls integer, dimension(:), allocatable :: calls_valid real(default), dimension(:), allocatable :: integral real(default), dimension(:), allocatable :: error real(default), dimension(:), allocatable :: efficiency type(vamp_history), dimension(:), allocatable :: v_history type(vamp_history), dimension(:,:), allocatable :: v_histories type(pass_t), pointer :: next => null () contains <> end type pass_t @ %def pass_t @ Finalizer. The VAMP histories contain a pointer array. <>= procedure :: final => pass_final <>= module subroutine pass_final (object) class(pass_t), intent(inout) :: object end subroutine pass_final <>= module subroutine pass_final (object) class(pass_t), intent(inout) :: object if (allocated (object%v_history)) then call vamp_delete_history (object%v_history) end if if (allocated (object%v_histories)) then call vamp_delete_history (object%v_histories) end if end subroutine pass_final @ %def pass_final @ Output. Note that the precision of the numerical values should match the precision for comparing output from file with data. <>= procedure :: write => pass_write <>= module subroutine pass_write (object, unit, pacify) class(pass_t), intent(in) :: object integer, intent(in) :: unit logical, intent(in), optional :: pacify end subroutine pass_write <>= module subroutine pass_write (object, unit, pacify) class(pass_t), intent(in) :: object integer, intent(in) :: unit logical, intent(in), optional :: pacify integer :: u, i character(len=7) :: fmt call pac_fmt (fmt, FMT_17, FMT_14, pacify) u = given_output_unit (unit) write (u, "(3x,A,I0)") "n_it = ", object%n_it write (u, "(3x,A,I0)") "n_calls = ", object%n_calls write (u, "(3x,A,I0)") "n_bins = ", object%n_bins write (u, "(3x,A,L1)") "adapt grids = ", object%adapt_grids write (u, "(3x,A,L1)") "adapt weights = ", object%adapt_weights if (object%integral_defined) then write (u, "(3x,A)") "Results: [it, calls, valid, integral, error, efficiency]" do i = 1, object%n_it write (u, "(5x,I0,2(1x,I0),3(1x," // fmt // "))") & i, object%calls(i), object%calls_valid(i), object%integral(i), object%error(i), & object%efficiency(i) end do else write (u, "(3x,A)") "Results: [undefined]" end if end subroutine pass_write @ %def pass_write @ Read and reconstruct the pass. <>= procedure :: read => pass_read <>= module subroutine pass_read (object, u, n_pass, n_it) class(pass_t), intent(out) :: object integer, intent(in) :: u, n_pass, n_it end subroutine pass_read <>= module subroutine pass_read (object, u, n_pass, n_it) class(pass_t), intent(out) :: object integer, intent(in) :: u, n_pass, n_it integer :: i, j character(80) :: buffer object%i_pass = n_pass + 1 object%i_first_it = n_it + 1 call read_ival (u, object%n_it) call read_ival (u, object%n_calls) call read_ival (u, object%n_bins) call read_lval (u, object%adapt_grids) call read_lval (u, object%adapt_weights) allocate (object%calls (object%n_it), source = 0) allocate (object%calls_valid (object%n_it), source = 0) allocate (object%integral (object%n_it), source = 0._default) allocate (object%error (object%n_it), source = 0._default) allocate (object%efficiency (object%n_it), source = 0._default) read (u, "(A)") buffer select case (trim (adjustl (buffer))) case ("Results: [it, calls, valid, integral, error, efficiency]") do i = 1, object%n_it read (u, *) & j, object%calls(i), object%calls_valid(i), object%integral(i), object%error(i), & object%efficiency(i) end do object%integral_defined = .true. case ("Results: [undefined]") object%integral_defined = .false. case default call msg_fatal ("Reading integration pass: corrupted file") end select end subroutine pass_read @ %def pass_read @ Write the VAMP history for this pass. (The subroutine writes the whole array at once.) <>= procedure :: write_history => pass_write_history <>= module subroutine pass_write_history (pass, unit) class(pass_t), intent(in) :: pass integer, intent(in), optional :: unit end subroutine pass_write_history <>= module subroutine pass_write_history (pass, unit) class(pass_t), intent(in) :: pass integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (allocated (pass%v_history)) then call vamp_write_history (u, pass%v_history) else write (u, "(1x,A)") "Global history: [undefined]" end if if (allocated (pass%v_histories)) then write (u, "(1x,A)") "Channel histories:" call vamp_write_history (u, pass%v_histories) else write (u, "(1x,A)") "Channel histories: [undefined]" end if end subroutine pass_write_history @ %def pass_write_history @ Given a number of calls and iterations, compute remaining data. <>= procedure :: configure => pass_configure <>= module subroutine pass_configure (pass, n_it, n_calls, min_calls, & min_bins, max_bins, min_channel_calls) class(pass_t), intent(inout) :: pass integer, intent(in) :: n_it, n_calls, min_channel_calls integer, intent(in) :: min_calls, min_bins, max_bins end subroutine pass_configure <>= module subroutine pass_configure (pass, n_it, n_calls, min_calls, & min_bins, max_bins, min_channel_calls) class(pass_t), intent(inout) :: pass integer, intent(in) :: n_it, n_calls, min_channel_calls integer, intent(in) :: min_calls, min_bins, max_bins pass%n_it = n_it if (min_calls /= 0) then pass%n_bins = max (min_bins, & min (n_calls / min_calls, max_bins)) else pass%n_bins = max_bins end if pass%n_calls = max (n_calls, max (min_calls, min_channel_calls)) if (pass%n_calls /= n_calls) then write (msg_buffer, "(A,I0)") "VAMP: too few calls, resetting " & // "n_calls to ", pass%n_calls call msg_warning () end if allocate (pass%calls (n_it), source = 0) allocate (pass%calls_valid (n_it), source = 0) allocate (pass%integral (n_it), source = 0._default) allocate (pass%error (n_it), source = 0._default) allocate (pass%efficiency (n_it), source = 0._default) end subroutine pass_configure @ %def pass_configure @ Allocate the VAMP history and give options. We assume that the [[configure]] routine above has been executed, so the number of iterations is known. <>= procedure :: configure_history => pass_configure_history <>= module subroutine pass_configure_history (pass, n_channels, par) class(pass_t), intent(inout) :: pass integer, intent(in) :: n_channels type(history_parameters_t), intent(in) :: par end subroutine pass_configure_history <>= module subroutine pass_configure_history (pass, n_channels, par) class(pass_t), intent(inout) :: pass integer, intent(in) :: n_channels type(history_parameters_t), intent(in) :: par if (par%global) then allocate (pass%v_history (pass%n_it)) call vamp_create_history (pass%v_history, & verbose = par%global_verbose) end if if (par%channel) then allocate (pass%v_histories (pass%n_it, n_channels)) call vamp_create_history (pass%v_histories, & verbose = par%channel_verbose) end if end subroutine pass_configure_history @ %def pass_configure_history @ Given two pass objects, compare them. All parameters must match. Where integrations are done in both (number of calls nonzero), the results must be equal (up to numerical noise). The allocated array sizes might be different, but should match up to the common [[n_it]] value. <>= interface operator (.matches.) module procedure pass_matches end interface operator (.matches.) <>= module function pass_matches (pass, ref) result (ok) type(pass_t), intent(in) :: pass, ref integer :: n logical :: ok end function pass_matches <>= module function pass_matches (pass, ref) result (ok) type(pass_t), intent(in) :: pass, ref integer :: n logical :: ok ok = .true. if (ok) ok = pass%i_pass == ref%i_pass if (ok) ok = pass%i_first_it == ref%i_first_it if (ok) ok = pass%n_it == ref%n_it if (ok) ok = pass%n_calls == ref%n_calls if (ok) ok = pass%n_bins == ref%n_bins if (ok) ok = pass%adapt_grids .eqv. ref%adapt_grids if (ok) ok = pass%adapt_weights .eqv. ref%adapt_weights if (ok) ok = pass%integral_defined .eqv. ref%integral_defined if (pass%integral_defined) then n = pass%n_it if (ok) ok = all (pass%calls(:n) == ref%calls(:n)) if (ok) ok = all (pass%calls_valid(:n) == ref%calls_valid (:n)) if (ok) ok = all (pass%integral(:n) .matches. ref%integral(:n)) if (ok) ok = all (pass%error(:n) .matches. ref%error(:n)) if (ok) ok = all (pass%efficiency(:n) .matches. ref%efficiency(:n)) end if end function pass_matches @ %def pass_matches @ Update a pass object, given a reference. The parameters must match, except for the [[n_it]] entry. The number of complete iterations must be less or equal to the reference, and the number of complete iterations in the reference must be no larger than [[n_it]]. Where results are present in both passes, they must match. Where results are present in the reference only, the pass is updated accordingly. <>= procedure :: update => pass_update <>= module subroutine pass_update (pass, ref, ok) class(pass_t), intent(inout) :: pass type(pass_t), intent(in) :: ref logical, intent(out) :: ok end subroutine pass_update <>= module subroutine pass_update (pass, ref, ok) class(pass_t), intent(inout) :: pass type(pass_t), intent(in) :: ref logical, intent(out) :: ok integer :: n, n_ref ok = .true. if (ok) ok = pass%i_pass == ref%i_pass if (ok) ok = pass%i_first_it == ref%i_first_it if (ok) ok = pass%n_calls == ref%n_calls if (ok) ok = pass%n_bins == ref%n_bins if (ok) ok = pass%adapt_grids .eqv. ref%adapt_grids if (ok) ok = pass%adapt_weights .eqv. ref%adapt_weights if (ok) then if (ref%integral_defined) then if (.not. allocated (pass%calls)) then allocate (pass%calls (pass%n_it), source = 0) allocate (pass%calls_valid (pass%n_it), source = 0) allocate (pass%integral (pass%n_it), source = 0._default) allocate (pass%error (pass%n_it), source = 0._default) allocate (pass%efficiency (pass%n_it), source = 0._default) end if n = count (pass%calls /= 0) n_ref = count (ref%calls /= 0) ok = n <= n_ref .and. n_ref <= pass%n_it if (ok) ok = all (pass%calls(:n) == ref%calls(:n)) if (ok) ok = all (pass%calls_valid(:n) == ref%calls_valid(:n)) if (ok) ok = all (pass%integral(:n) .matches. ref%integral(:n)) if (ok) ok = all (pass%error(:n) .matches. ref%error(:n)) if (ok) ok = all (pass%efficiency(:n) .matches. ref%efficiency(:n)) if (ok) then pass%calls(n+1:n_ref) = ref%calls(n+1:n_ref) pass%calls_valid(n+1:n_ref) = ref%calls_valid(n+1:n_ref) pass%integral(n+1:n_ref) = ref%integral(n+1:n_ref) pass%error(n+1:n_ref) = ref%error(n+1:n_ref) pass%efficiency(n+1:n_ref) = ref%efficiency(n+1:n_ref) pass%integral_defined = any (pass%calls /= 0) end if end if end if end subroutine pass_update @ %def pass_update @ Match two real numbers: they are equal up to a tolerance, which is $10^{-8}$, matching the number of digits that are output by [[pass_write]]. In particular, if one number is exactly zero, the other one must also be zero. <>= interface operator (.matches.) module procedure real_matches end interface operator (.matches.) <>= elemental module function real_matches (x, y) result (ok) real(default), intent(in) :: x, y logical :: ok end function real_matches <>= elemental module function real_matches (x, y) result (ok) real(default), intent(in) :: x, y logical :: ok real(default), parameter :: tolerance = 1.e-8_default ok = abs (x - y) <= tolerance * max (abs (x), abs (y)) end function real_matches @ %def real_matches @ Return the index of the most recent complete integration. If there is none, return zero. <>= procedure :: get_integration_index => pass_get_integration_index <>= module function pass_get_integration_index (pass) result (n) class (pass_t), intent(in) :: pass integer :: n end function pass_get_integration_index <>= module function pass_get_integration_index (pass) result (n) class (pass_t), intent(in) :: pass integer :: n integer :: i n = 0 if (allocated (pass%calls)) then do i = 1, pass%n_it if (pass%calls(i) == 0) exit n = i end do end if end function pass_get_integration_index @ %def pass_get_integration_index @ Return the most recent integral and error, if available. <>= procedure :: get_calls => pass_get_calls procedure :: get_calls_valid => pass_get_calls_valid procedure :: get_integral => pass_get_integral procedure :: get_error => pass_get_error procedure :: get_efficiency => pass_get_efficiency <>= module function pass_get_calls (pass) result (calls) class(pass_t), intent(in) :: pass integer :: calls end function pass_get_calls module function pass_get_calls_valid (pass) result (calls_valid) class(pass_t), intent(in) :: pass integer :: calls_valid end function pass_get_calls_valid module function pass_get_integral (pass) result (integral) class(pass_t), intent(in) :: pass real(default) :: integral end function pass_get_integral module function pass_get_error (pass) result (error) class(pass_t), intent(in) :: pass real(default) :: error end function pass_get_error module function pass_get_efficiency (pass) result (efficiency) class(pass_t), intent(in) :: pass real(default) :: efficiency end function pass_get_efficiency <>= module function pass_get_calls (pass) result (calls) class(pass_t), intent(in) :: pass integer :: calls integer :: n n = pass%get_integration_index () if (n /= 0) then calls = pass%calls(n) else calls = 0 end if end function pass_get_calls module function pass_get_calls_valid (pass) result (calls_valid) class(pass_t), intent(in) :: pass integer :: calls_valid integer :: n n = pass%get_integration_index () if (n /= 0) then calls_valid = pass%calls_valid(n) else calls_valid = 0 end if end function pass_get_calls_valid module function pass_get_integral (pass) result (integral) class(pass_t), intent(in) :: pass real(default) :: integral integer :: n n = pass%get_integration_index () if (n /= 0) then integral = pass%integral(n) else integral = 0 end if end function pass_get_integral module function pass_get_error (pass) result (error) class(pass_t), intent(in) :: pass real(default) :: error integer :: n n = pass%get_integration_index () if (n /= 0) then error = pass%error(n) else error = 0 end if end function pass_get_error module function pass_get_efficiency (pass) result (efficiency) class(pass_t), intent(in) :: pass real(default) :: efficiency integer :: n n = pass%get_integration_index () if (n /= 0) then efficiency = pass%efficiency(n) else efficiency = 0 end if end function pass_get_efficiency @ %def pass_get_calls @ %def pass_get_calls_valid @ %def pass_get_integral @ %def pass_get_error @ %def pass_get_efficiency @ \subsection{Integrator} <>= public :: mci_vamp_t <>= type, extends (mci_t) :: mci_vamp_t logical, dimension(:), allocatable :: dim_is_flat type(grid_parameters_t) :: grid_par type(history_parameters_t) :: history_par integer :: min_calls = 0 type(pass_t), pointer :: first_pass => null () type(pass_t), pointer :: current_pass => null () type(vamp_equivalences_t) :: equivalences logical :: rebuild = .true. logical :: check_grid_file = .true. logical :: grid_filename_set = .false. logical :: negative_weights = .false. logical :: verbose = .false. type(string_t) :: grid_filename character(32) :: md5sum_adapted = "" contains <> end type mci_vamp_t @ %def mci_vamp_t @ Reset: delete integration-pass entries. <>= procedure :: reset => mci_vamp_reset <>= module subroutine mci_vamp_reset (object) class(mci_vamp_t), intent(inout) :: object end subroutine mci_vamp_reset <>= module subroutine mci_vamp_reset (object) class(mci_vamp_t), intent(inout) :: object type(pass_t), pointer :: current_pass do while (associated (object%first_pass)) current_pass => object%first_pass object%first_pass => current_pass%next call current_pass%final () deallocate (current_pass) end do object%current_pass => null () end subroutine mci_vamp_reset @ %def mci_vamp_reset @ Finalizer: reset and finalize the equivalences list. <>= procedure :: final => mci_vamp_final <>= module subroutine mci_vamp_final (object) class(mci_vamp_t), intent(inout) :: object end subroutine mci_vamp_final <>= module subroutine mci_vamp_final (object) class(mci_vamp_t), intent(inout) :: object call object%reset () call vamp_equivalences_final (object%equivalences) call object%base_final () end subroutine mci_vamp_final @ %def mci_vamp_final @ Output. Do not output the grids themselves, this may result in tons of data. <>= procedure :: write => mci_vamp_write <>= module subroutine mci_vamp_write (object, unit, pacify, md5sum_version) class(mci_vamp_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version end subroutine mci_vamp_write <>= module subroutine mci_vamp_write (object, unit, pacify, md5sum_version) class(mci_vamp_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version type(pass_t), pointer :: current_pass integer :: u, i u = given_output_unit (unit) write (u, "(1x,A)") "VAMP integrator:" call object%base_write (u, pacify, md5sum_version) if (allocated (object%dim_is_flat)) then write (u, "(3x,A,999(1x,I0))") "Flat dimensions =", & pack ([(i, i = 1, object%n_dim)], object%dim_is_flat) end if write (u, "(1x,A)") "Grid parameters:" call object%grid_par%write (u) write (u, "(3x,A,I0)") "min_calls = ", object%min_calls write (u, "(3x,A,L1)") "negative weights = ", & object%negative_weights write (u, "(3x,A,L1)") "verbose = ", & object%verbose if (object%grid_par%use_vamp_equivalences) then call vamp_equivalences_write (object%equivalences, u) end if current_pass => object%first_pass do while (associated (current_pass)) write (u, "(1x,A,I0,A)") "Integration pass:" call current_pass%write (u, pacify) current_pass => current_pass%next end do if (object%md5sum_adapted /= "") then write (u, "(1x,A,A,A)") "MD5 sum (including results) = '", & object%md5sum_adapted, "'" end if end subroutine mci_vamp_write @ %def mci_vamp_write @ Write the history parameters. <>= procedure :: write_history_parameters => mci_vamp_write_history_parameters <>= module subroutine mci_vamp_write_history_parameters (mci, unit) class(mci_vamp_t), intent(in) :: mci integer, intent(in), optional :: unit end subroutine mci_vamp_write_history_parameters <>= module subroutine mci_vamp_write_history_parameters (mci, unit) class(mci_vamp_t), intent(in) :: mci integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "VAMP history parameters:" call mci%history_par%write (unit) end subroutine mci_vamp_write_history_parameters @ %def mci_vamp_write_history_parameters @ Write the history, iterating over passes. We keep this separate from the generic [[write]] routine. <>= procedure :: write_history => mci_vamp_write_history <>= module subroutine mci_vamp_write_history (mci, unit) class(mci_vamp_t), intent(in) :: mci integer, intent(in), optional :: unit end subroutine mci_vamp_write_history <>= module subroutine mci_vamp_write_history (mci, unit) class(mci_vamp_t), intent(in) :: mci integer, intent(in), optional :: unit type(pass_t), pointer :: current_pass integer :: i_pass integer :: u u = given_output_unit (unit) if (associated (mci%first_pass)) then write (u, "(1x,A)") "VAMP history (global):" i_pass = 0 current_pass => mci%first_pass do while (associated (current_pass)) i_pass = i_pass + 1 write (u, "(1x,A,I0,':')") "Pass #", i_pass call current_pass%write_history (u) current_pass => current_pass%next end do end if end subroutine mci_vamp_write_history @ %def mci_vamp_write_history @ Compute the MD5 sum, including the configuration MD5 sum and the printout, which incorporates the current results. <>= procedure :: compute_md5sum => mci_vamp_compute_md5sum <>= module subroutine mci_vamp_compute_md5sum (mci, pacify) class(mci_vamp_t), intent(inout) :: mci logical, intent(in), optional :: pacify end subroutine mci_vamp_compute_md5sum <>= module subroutine mci_vamp_compute_md5sum (mci, pacify) class(mci_vamp_t), intent(inout) :: mci logical, intent(in), optional :: pacify integer :: u mci%md5sum_adapted = "" u = free_unit () open (u, status = "scratch", action = "readwrite") write (u, "(A)") mci%md5sum call mci%write (u, pacify, md5sum_version = .true.) rewind (u) mci%md5sum_adapted = md5sum (u) close (u) end subroutine mci_vamp_compute_md5sum @ %def mci_vamp_compute_md5sum @ Return the MD5 sum: If available, return the adapted one. <>= procedure :: get_md5sum => mci_vamp_get_md5sum <>= pure module function mci_vamp_get_md5sum (mci) result (md5sum) class(mci_vamp_t), intent(in) :: mci character(32) :: md5sum end function mci_vamp_get_md5sum <>= pure module function mci_vamp_get_md5sum (mci) result (md5sum) class(mci_vamp_t), intent(in) :: mci character(32) :: md5sum if (mci%md5sum_adapted /= "") then md5sum = mci%md5sum_adapted else md5sum = mci%md5sum end if end function mci_vamp_get_md5sum @ %def mci_vamp_get_md5sum @ Startup message: short version. <>= procedure :: startup_message => mci_vamp_startup_message <>= module subroutine mci_vamp_startup_message (mci, unit, n_calls) class(mci_vamp_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls end subroutine mci_vamp_startup_message <>= module subroutine mci_vamp_startup_message (mci, unit, n_calls) class(mci_vamp_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls integer :: num_calls, n_bins if (present (n_calls)) then num_calls = n_calls else num_calls = 0 end if if (mci%min_calls /= 0) then n_bins = max (mci%grid_par%min_bins, & min (num_calls / mci%min_calls, & mci%grid_par%max_bins)) else n_bins = mci%grid_par%max_bins end if call mci%base_startup_message (unit = unit, n_calls = n_calls) if (mci%grid_par%use_vamp_equivalences) then write (msg_buffer, "(A,2(1x,I0,1x,A))") & "Integrator: Using VAMP channel equivalences" call msg_message (unit = unit) end if write (msg_buffer, "(A,2(1x,I0,1x,A),L1)") & "Integrator:", num_calls, & "initial calls,", n_bins, & "bins, stratified = ", & mci%grid_par%stratified call msg_message (unit = unit) write (msg_buffer, "(A,2(1x,I0,1x,A))") & "Integrator: VAMP" call msg_message (unit = unit) end subroutine mci_vamp_startup_message @ %def mci_vamp_startup_message @ Log entry: just headline. <>= procedure :: write_log_entry => mci_vamp_write_log_entry <>= module subroutine mci_vamp_write_log_entry (mci, u) class(mci_vamp_t), intent(in) :: mci integer, intent(in) :: u end subroutine mci_vamp_write_log_entry <>= module subroutine mci_vamp_write_log_entry (mci, u) class(mci_vamp_t), intent(in) :: mci integer, intent(in) :: u write (u, "(1x,A)") "MC Integrator is VAMP" call write_separator (u) call mci%write_history (u) call write_separator (u) if (mci%grid_par%use_vamp_equivalences) then call vamp_equivalences_write (mci%equivalences, u) else write (u, "(3x,A)") "No VAMP equivalences have been used" end if call write_separator (u) call mci%write_chain_weights (u) end subroutine mci_vamp_write_log_entry @ %def mci_vamp_write_log_entry @ Set the MCI index (necessary for processes with multiple components). We append the index to the grid filename, just before the final dotted suffix. <>= procedure :: record_index => mci_vamp_record_index <>= module subroutine mci_vamp_record_index (mci, i_mci) class(mci_vamp_t), intent(inout) :: mci integer, intent(in) :: i_mci end subroutine mci_vamp_record_index <>= module subroutine mci_vamp_record_index (mci, i_mci) class(mci_vamp_t), intent(inout) :: mci integer, intent(in) :: i_mci type(string_t) :: basename, suffix character(32) :: buffer if (mci%grid_filename_set) then basename = mci%grid_filename call split (basename, suffix, ".", back=.true.) write (buffer, "(I0)") i_mci if (basename /= "") then mci%grid_filename = basename // ".m" // trim (buffer) // "." // suffix else mci%grid_filename = suffix // ".m" // trim (buffer) // ".vg" end if end if end subroutine mci_vamp_record_index @ %def mci_vamp_record_index @ Set the grid parameters. <>= procedure :: set_grid_parameters => mci_vamp_set_grid_parameters <>= module subroutine mci_vamp_set_grid_parameters (mci, grid_par) class(mci_vamp_t), intent(inout) :: mci type(grid_parameters_t), intent(in) :: grid_par end subroutine mci_vamp_set_grid_parameters <>= module subroutine mci_vamp_set_grid_parameters (mci, grid_par) class(mci_vamp_t), intent(inout) :: mci type(grid_parameters_t), intent(in) :: grid_par mci%grid_par = grid_par mci%min_calls = grid_par%min_calls_per_bin * mci%n_channel end subroutine mci_vamp_set_grid_parameters @ %def mci_vamp_set_grid_parameters @ Set the history parameters. <>= procedure :: set_history_parameters => mci_vamp_set_history_parameters <>= module subroutine mci_vamp_set_history_parameters (mci, history_par) class(mci_vamp_t), intent(inout) :: mci type(history_parameters_t), intent(in) :: history_par end subroutine mci_vamp_set_history_parameters <>= module subroutine mci_vamp_set_history_parameters (mci, history_par) class(mci_vamp_t), intent(inout) :: mci type(history_parameters_t), intent(in) :: history_par mci%history_par = history_par end subroutine mci_vamp_set_history_parameters @ %def mci_vamp_set_history_parameters @ Set the rebuild flag, also the flag for checking the grid file. <>= procedure :: set_rebuild_flag => mci_vamp_set_rebuild_flag <>= module subroutine mci_vamp_set_rebuild_flag (mci, rebuild, check_grid_file) class(mci_vamp_t), intent(inout) :: mci logical, intent(in) :: rebuild logical, intent(in) :: check_grid_file end subroutine mci_vamp_set_rebuild_flag <>= module subroutine mci_vamp_set_rebuild_flag (mci, rebuild, check_grid_file) class(mci_vamp_t), intent(inout) :: mci logical, intent(in) :: rebuild logical, intent(in) :: check_grid_file mci%rebuild = rebuild mci%check_grid_file = check_grid_file end subroutine mci_vamp_set_rebuild_flag @ %def mci_vamp_set_rebuild_flag @ Set the filename. <>= procedure :: set_grid_filename => mci_vamp_set_grid_filename <>= module subroutine mci_vamp_set_grid_filename (mci, name, run_id) class(mci_vamp_t), intent(inout) :: mci type(string_t), intent(in) :: name type(string_t), intent(in), optional :: run_id end subroutine mci_vamp_set_grid_filename <>= module subroutine mci_vamp_set_grid_filename (mci, name, run_id) class(mci_vamp_t), intent(inout) :: mci type(string_t), intent(in) :: name type(string_t), intent(in), optional :: run_id if (present (run_id)) then mci%grid_filename = name // "." // run_id // ".vg" else mci%grid_filename = name // ".vg" end if mci%grid_filename_set = .true. end subroutine mci_vamp_set_grid_filename @ %def mci_vamp_set_grid_filename @ To simplify the interface, we prepend a grid path in a separate subroutine. <>= procedure :: prepend_grid_path => mci_vamp_prepend_grid_path <>= module subroutine mci_vamp_prepend_grid_path (mci, prefix) class(mci_vamp_t), intent(inout) :: mci type(string_t), intent(in) :: prefix end subroutine mci_vamp_prepend_grid_path <>= module subroutine mci_vamp_prepend_grid_path (mci, prefix) class(mci_vamp_t), intent(inout) :: mci type(string_t), intent(in) :: prefix if (mci%grid_filename_set) then mci%grid_filename = prefix // "/" // mci%grid_filename else call msg_warning ("Cannot add prefix to invalid grid filename!") end if end subroutine mci_vamp_prepend_grid_path @ %def mci_vamp_prepend_grid_path @ Declare particular dimensions as flat. <>= procedure :: declare_flat_dimensions => mci_vamp_declare_flat_dimensions <>= module subroutine mci_vamp_declare_flat_dimensions (mci, dim_flat) class(mci_vamp_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat end subroutine mci_vamp_declare_flat_dimensions <>= module subroutine mci_vamp_declare_flat_dimensions (mci, dim_flat) class(mci_vamp_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat integer :: d allocate (mci%dim_is_flat (mci%n_dim), source = .false.) do d = 1, size (dim_flat) mci%dim_is_flat(dim_flat(d)) = .true. end do end subroutine mci_vamp_declare_flat_dimensions @ %def mci_vamp_declare_flat_dimensions @ Declare equivalences. We have an array of channel equivalences, provided by the phase-space module. Here, we translate this into the [[vamp_equivalences]] array. <>= procedure :: declare_equivalences => mci_vamp_declare_equivalences <>= module subroutine mci_vamp_declare_equivalences (mci, channel, dim_offset) class(mci_vamp_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset end subroutine mci_vamp_declare_equivalences <>= module subroutine mci_vamp_declare_equivalences (mci, channel, dim_offset) class(mci_vamp_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset integer, dimension(:), allocatable :: perm, mode integer :: n_channels, n_dim, n_equivalences integer :: c, i, j, left, right integer :: n_dim_perm n_channels = mci%n_channel n_dim = mci%n_dim n_equivalences = 0 do c = 1, n_channels n_equivalences = n_equivalences + size (channel(c)%eq) end do call vamp_equivalences_init (mci%equivalences, & n_equivalences, n_channels, n_dim) allocate (perm (n_dim)) allocate (mode (n_dim)) perm = [(i, i = 1, n_dim)] mode = VEQ_IDENTITY c = 1 j = 0 do i = 1, n_equivalences if (j < size (channel(c)%eq)) then j = j + 1 else c = c + 1 j = 1 end if associate (eq => channel(c)%eq(j)) left = c right = eq%c n_dim_perm = size (eq%perm) perm(dim_offset + 1:dim_offset + n_dim_perm) = eq%perm + dim_offset mode(dim_offset + 1:dim_offset + n_dim_perm) = eq%mode call vamp_equivalence_set (mci%equivalences, & i, left, right, perm, mode) end associate end do call vamp_equivalences_complete (mci%equivalences) end subroutine mci_vamp_declare_equivalences @ %def mci_vamp_declare_equivalences @ Allocate instance with matching type. Gfortran 7/8/9 bug, has to remain in the main module: <>= procedure :: allocate_instance => mci_vamp_allocate_instance <>= subroutine mci_vamp_allocate_instance (mci, mci_instance) class(mci_vamp_t), intent(in) :: mci class(mci_instance_t), intent(out), pointer :: mci_instance allocate (mci_vamp_instance_t :: mci_instance) end subroutine mci_vamp_allocate_instance @ %def mci_vamp_allocate_instance @ Allocate a new integration pass. We can preset everything that does not depend on the number of iterations and calls. This is postponed to the [[integrate]] method. In the final pass, we do not check accuracy goal etc., since we can assume that the user wants to perform and average all iterations in this pass. <>= procedure :: add_pass => mci_vamp_add_pass <>= module subroutine mci_vamp_add_pass & (mci, adapt_grids, adapt_weights, final_pass) class(mci_vamp_t), intent(inout) :: mci logical, intent(in), optional :: adapt_grids, adapt_weights, final_pass end subroutine mci_vamp_add_pass <>= module subroutine mci_vamp_add_pass & (mci, adapt_grids, adapt_weights, final_pass) class(mci_vamp_t), intent(inout) :: mci logical, intent(in), optional :: adapt_grids, adapt_weights, final_pass integer :: i_pass, i_it type(pass_t), pointer :: new allocate (new) if (associated (mci%current_pass)) then i_pass = mci%current_pass%i_pass + 1 i_it = mci%current_pass%i_first_it + mci%current_pass%n_it mci%current_pass%next => new else i_pass = 1 i_it = 1 mci%first_pass => new end if mci%current_pass => new new%i_pass = i_pass new%i_first_it = i_it if (present (adapt_grids)) then new%adapt_grids = adapt_grids else new%adapt_grids = .false. end if if (present (adapt_weights)) then new%adapt_weights = adapt_weights else new%adapt_weights = .false. end if if (present (final_pass)) then new%is_final_pass = final_pass else new%is_final_pass = .false. end if end subroutine mci_vamp_add_pass @ %def mci_vamp_add_pass @ Update the list of integration passes. All passes except for the last one must match exactly. For the last one, integration results are updated. The reference output may contain extra passes, these are ignored. <>= procedure :: update_from_ref => mci_vamp_update_from_ref <>= module subroutine mci_vamp_update_from_ref (mci, mci_ref, success) class(mci_vamp_t), intent(inout) :: mci class(mci_t), intent(in) :: mci_ref logical, intent(out) :: success end subroutine mci_vamp_update_from_ref <>= module subroutine mci_vamp_update_from_ref (mci, mci_ref, success) class(mci_vamp_t), intent(inout) :: mci class(mci_t), intent(in) :: mci_ref logical, intent(out) :: success type(pass_t), pointer :: current_pass, ref_pass select type (mci_ref) type is (mci_vamp_t) current_pass => mci%first_pass ref_pass => mci_ref%first_pass success = .true. do while (success .and. associated (current_pass)) if (associated (ref_pass)) then if (associated (current_pass%next)) then success = current_pass .matches. ref_pass else call current_pass%update (ref_pass, success) if (current_pass%integral_defined) then mci%integral = current_pass%get_integral () mci%error = current_pass%get_error () mci%efficiency = current_pass%get_efficiency () mci%integral_known = .true. mci%error_known = .true. mci%efficiency_known = .true. end if end if current_pass => current_pass%next ref_pass => ref_pass%next else success = .false. end if end do end select end subroutine mci_vamp_update_from_ref @ %def mci_vamp_update @ Update the MCI record (i.e., the integration passes) by reading from input stream. The stream should contain a [[write]] output from a previous run. We first check the MD5 sum of the configuration parameters. If that matches, we proceed directly to the stored integration passes. If successful, we may continue to read the file; the position will be after a blank line that must follow the MCI record. <>= procedure :: update => mci_vamp_update <>= module subroutine mci_vamp_update (mci, u, success) class(mci_vamp_t), intent(inout) :: mci integer, intent(in) :: u logical, intent(out) :: success end subroutine mci_vamp_update <>= module subroutine mci_vamp_update (mci, u, success) class(mci_vamp_t), intent(inout) :: mci integer, intent(in) :: u logical, intent(out) :: success character(80) :: buffer character(32) :: md5sum_file type(mci_vamp_t) :: mci_file integer :: n_pass, n_it call read_sval (u, md5sum_file) if (mci%check_grid_file) then success = md5sum_file == mci%md5sum else success = .true. end if if (success) then read (u, *) read (u, "(A)") buffer if (trim (adjustl (buffer)) == "VAMP integrator:") then n_pass = 0 n_it = 0 do read (u, "(A)") buffer select case (trim (adjustl (buffer))) case ("") exit case ("Integration pass:") call mci_file%add_pass () call mci_file%current_pass%read (u, n_pass, n_it) n_pass = n_pass + 1 n_it = n_it + mci_file%current_pass%n_it end select end do call mci%update_from_ref (mci_file, success) call mci_file%final () else call msg_fatal ("VAMP: reading grid file: corrupted data") end if end if end subroutine mci_vamp_update @ %def mci_vamp_update @ Read / write grids from / to file. Bug fix for 2.2.5: after reading grids from file, channel weights must be copied back to the [[mci_instance]] record. <>= procedure :: write_grids => mci_vamp_write_grids procedure :: read_grids_header => mci_vamp_read_grids_header procedure :: read_grids_data => mci_vamp_read_grids_data procedure :: read_grids => mci_vamp_read_grids <>= module subroutine mci_vamp_write_grids (mci, instance) class(mci_vamp_t), intent(in) :: mci class(mci_instance_t), intent(inout) :: instance end subroutine mci_vamp_write_grids module subroutine mci_vamp_read_grids_header (mci, success) class(mci_vamp_t), intent(inout) :: mci logical, intent(out) :: success end subroutine mci_vamp_read_grids_header module subroutine mci_vamp_read_grids_data (mci, instance, read_integrals) class(mci_vamp_t), intent(in) :: mci class(mci_instance_t), intent(inout) :: instance logical, intent(in), optional :: read_integrals end subroutine mci_vamp_read_grids_data module subroutine mci_vamp_read_grids (mci, instance, success) class(mci_vamp_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance logical, intent(out) :: success end subroutine mci_vamp_read_grids <>= module subroutine mci_vamp_write_grids (mci, instance) class(mci_vamp_t), intent(in) :: mci class(mci_instance_t), intent(inout) :: instance integer :: u select type (instance) type is (mci_vamp_instance_t) if (mci%grid_filename_set) then if (instance%grids_defined) then u = free_unit () open (u, file = char (mci%grid_filename), & action = "write", status = "replace") write (u, "(1x,A,A,A)") "MD5sum = '", mci%md5sum, "'" write (u, *) call mci%write (u) write (u, *) write (u, "(1x,A)") "VAMP grids:" call vamp_write_grids (instance%grids, u, & write_integrals = .true.) close (u) else call msg_bug ("VAMP: write grids: grids undefined") end if else call msg_bug ("VAMP: write grids: filename undefined") end if end select end subroutine mci_vamp_write_grids module subroutine mci_vamp_read_grids_header (mci, success) class(mci_vamp_t), intent(inout) :: mci logical, intent(out) :: success logical :: exist integer :: u success = .false. if (mci%grid_filename_set) then inquire (file = char (mci%grid_filename), exist = exist) if (exist) then u = free_unit () open (u, file = char (mci%grid_filename), & action = "read", status = "old") call mci%update (u, success) close (u) if (.not. success) then write (msg_buffer, "(A,A,A)") & "VAMP: parameter mismatch, discarding grid file '", & char (mci%grid_filename), "'" call msg_message () end if end if else call msg_bug ("VAMP: read grids: filename undefined") end if end subroutine mci_vamp_read_grids_header module subroutine mci_vamp_read_grids_data (mci, instance, read_integrals) class(mci_vamp_t), intent(in) :: mci class(mci_instance_t), intent(inout) :: instance logical, intent(in), optional :: read_integrals integer :: u character(80) :: buffer select type (instance) type is (mci_vamp_instance_t) if (.not. instance%grids_defined) then u = free_unit () open (u, file = char (mci%grid_filename), & action = "read", status = "old") do read (u, "(A)") buffer if (trim (adjustl (buffer)) == "VAMP grids:") exit end do call vamp_read_grids (instance%grids, u, read_integrals) close (u) call instance%set_channel_weights (instance%grids%weights) instance%grids_defined = .true. else call msg_bug ("VAMP: read grids: grids already defined") end if end select end subroutine mci_vamp_read_grids_data module subroutine mci_vamp_read_grids (mci, instance, success) class(mci_vamp_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance logical, intent(out) :: success logical :: exist integer :: u character(80) :: buffer select type (instance) type is (mci_vamp_instance_t) success = .false. if (mci%grid_filename_set) then if (.not. instance%grids_defined) then inquire (file = char (mci%grid_filename), exist = exist) if (exist) then u = free_unit () open (u, file = char (mci%grid_filename), & action = "read", status = "old") call mci%update (u, success) if (success) then read (u, "(A)") buffer if (trim (adjustl (buffer)) == "VAMP grids:") then call vamp_read_grids (instance%grids, u) else call msg_fatal ("VAMP: reading grid file: & &corrupted grid data") end if else write (msg_buffer, "(A,A,A)") & "VAMP: parameter mismatch, discarding grid file '", & char (mci%grid_filename), "'" call msg_message () end if close (u) instance%grids_defined = success end if else call msg_bug ("VAMP: read grids: grids already defined") end if else call msg_bug ("VAMP: read grids: filename undefined") end if end select end subroutine mci_vamp_read_grids @ %def mci_vamp_write_grids @ %def mci_vamp_read_grids_header @ %def mci_vamp_read_grids_data @ %def mci_vamp_read_grids @ Auxiliary: Read real, integer, string value. We search for an equals sign, the value must follow. <>= subroutine read_rval (u, rval) integer, intent(in) :: u real(default), intent(out) :: rval character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) rval end subroutine read_rval subroutine read_ival (u, ival) integer, intent(in) :: u integer, intent(out) :: ival character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) ival end subroutine read_ival subroutine read_sval (u, sval) integer, intent(in) :: u character(*), intent(out) :: sval character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) sval end subroutine read_sval subroutine read_lval (u, lval) integer, intent(in) :: u logical, intent(out) :: lval character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) lval end subroutine read_lval @ %def read_rval read_ival read_sval read_lval @ Integrate. Perform a new integration pass (possibly reusing previous results), which may consist of several iterations. Note: we record the integral once per iteration. The integral stored in the [[mci]] record itself is the last integral of the current iteration, no averaging done. The [[results]] record may average results. In case we read the integration from file and we added new iterations to the pass preserving number of calls, we need to reshape the grids in order to incorporate the correct number of calls. Else the grids would be sampled with the number of calls from the grids file, which does not need to coincide with the number of calls from the pass. Note: recording the efficiency is not supported yet. <>= procedure :: integrate => mci_vamp_integrate <>= module subroutine mci_vamp_integrate (mci, instance, sampler, & n_it, n_calls, results, pacify) class(mci_vamp_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls class(mci_results_t), intent(inout), optional :: results logical, intent(in), optional :: pacify end subroutine mci_vamp_integrate <>= module subroutine mci_vamp_integrate (mci, instance, sampler, & n_it, n_calls, results, pacify) class(mci_vamp_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls class(mci_results_t), intent(inout), optional :: results logical, intent(in), optional :: pacify integer :: it logical :: reshape, from_file, success select type (instance) type is (mci_vamp_instance_t) if (associated (mci%current_pass)) then mci%current_pass%integral_defined = .false. call mci%current_pass%configure (n_it, n_calls, & mci%min_calls, mci%grid_par%min_bins, & mci%grid_par%max_bins, & mci%grid_par%min_calls_per_channel * mci%n_channel) call mci%current_pass%configure_history & (mci%n_channel, mci%history_par) instance%pass_complete = .false. instance%it_complete = .false. call instance%new_pass (reshape) if (.not. instance%grids_defined .or. instance%grids_from_file) then if (mci%grid_filename_set .and. .not. mci%rebuild) then call mci%read_grids_header (success) from_file = success if (.not. instance%grids_defined .and. success) then call mci%read_grids_data (instance) end if else from_file = .false. end if else from_file = .false. end if if (from_file) then if (.not. mci%check_grid_file) & call msg_warning ("Reading grid file: MD5 sum check disabled") call msg_message ("VAMP: " & // "using grids and results from file '" & // char (mci%grid_filename) // "'") else if (.not. instance%grids_defined) then call instance%create_grids () end if do it = 1, instance%n_it if (signal_is_pending ()) return reshape = reshape .or. & (instance%grids_from_file .and. n_it > mci%current_pass%get_integration_index ()) instance%grids_from_file = from_file .and. & it <= mci%current_pass%get_integration_index () if (.not. instance%grids_from_file) then instance%it_complete = .false. call instance%adapt_grids () if (signal_is_pending ()) return call instance%adapt_weights () if (signal_is_pending ()) return call instance%discard_integrals (reshape) if (mci%grid_par%use_vamp_equivalences) then call instance%sample_grids (mci%rng, sampler, & mci%equivalences) else call instance%sample_grids (mci%rng, sampler) end if if (signal_is_pending ()) return instance%it_complete = .true. if (instance%integral /= 0) then mci%current_pass%calls(it) = instance%calls mci%current_pass%calls_valid(it) = instance%calls_valid mci%current_pass%integral(it) = instance%integral if (abs (instance%error / instance%integral) & > epsilon (1._default)) then mci%current_pass%error(it) = instance%error end if mci%current_pass%efficiency(it) = instance%efficiency end if mci%current_pass%integral_defined = .true. end if if (present (results)) then if (mci%has_chains ()) then call mci%collect_chain_weights (instance%w) call results%record (1, & n_calls = mci%current_pass%calls(it), & n_calls_valid = mci%current_pass%calls_valid(it), & integral = mci%current_pass%integral(it), & error = mci%current_pass%error(it), & efficiency = mci%current_pass%efficiency(it), & ! TODO Insert pos. and neg. Efficiency from VAMP. efficiency_pos = 0._default, & efficiency_neg = 0._default, & chain_weights = mci%chain_weights, & suppress = pacify) else call results%record (1, & n_calls = mci%current_pass%calls(it), & n_calls_valid = mci%current_pass%calls_valid(it), & integral = mci%current_pass%integral(it), & error = mci%current_pass%error(it), & efficiency = mci%current_pass%efficiency(it), & ! TODO Insert pos. and neg. Efficiency from VAMP. efficiency_pos = 0._default, & efficiency_neg = 0._default, & suppress = pacify) end if end if if (.not. instance%grids_from_file & .and. mci%grid_filename_set) then call mci%write_grids (instance) end if call instance%allow_adaptation () reshape = .false. if (.not. mci%current_pass%is_final_pass) then call mci%check_goals (it, success) if (success) exit end if end do if (signal_is_pending ()) return instance%pass_complete = .true. mci%integral = mci%current_pass%get_integral() mci%error = mci%current_pass%get_error() mci%efficiency = mci%current_pass%get_efficiency() mci%integral_known = .true. mci%error_known = .true. mci%efficiency_known = .true. call mci%compute_md5sum (pacify) else call msg_bug ("MCI integrate: current_pass object not allocated") end if end select end subroutine mci_vamp_integrate @ %def mci_vamp_integrate @ Check whether we are already finished with this pass. <>= procedure :: check_goals => mci_vamp_check_goals <>= module subroutine mci_vamp_check_goals (mci, it, success) class(mci_vamp_t), intent(inout) :: mci integer, intent(in) :: it logical, intent(out) :: success end subroutine mci_vamp_check_goals <>= module subroutine mci_vamp_check_goals (mci, it, success) class(mci_vamp_t), intent(inout) :: mci integer, intent(in) :: it logical, intent(out) :: success success = .false. if (mci%error_reached (it)) then mci%current_pass%n_it = it call msg_message ("VAMP: error goal reached; & &skipping iterations") success = .true. return end if if (mci%rel_error_reached (it)) then mci%current_pass%n_it = it call msg_message ("VAMP: relative error goal reached; & &skipping iterations") success = .true. return end if if (mci%accuracy_reached (it)) then mci%current_pass%n_it = it call msg_message ("VAMP: accuracy goal reached; & &skipping iterations") success = .true. return end if end subroutine mci_vamp_check_goals @ %def mci_vamp_check_goals @ Return true if the error, relative error, or accuracy goal has been reached, if any. <>= procedure :: error_reached => mci_vamp_error_reached procedure :: rel_error_reached => mci_vamp_rel_error_reached procedure :: accuracy_reached => mci_vamp_accuracy_reached <>= module function mci_vamp_error_reached (mci, it) result (flag) class(mci_vamp_t), intent(in) :: mci integer, intent(in) :: it logical :: flag end function mci_vamp_error_reached module function mci_vamp_rel_error_reached (mci, it) result (flag) class(mci_vamp_t), intent(in) :: mci integer, intent(in) :: it logical :: flag end function mci_vamp_rel_error_reached module function mci_vamp_accuracy_reached (mci, it) result (flag) class(mci_vamp_t), intent(in) :: mci integer, intent(in) :: it logical :: flag end function mci_vamp_accuracy_reached <>= module function mci_vamp_error_reached (mci, it) result (flag) class(mci_vamp_t), intent(in) :: mci integer, intent(in) :: it logical :: flag real(default) :: error_goal, error error_goal = mci%grid_par%error_goal if (error_goal > 0) then associate (pass => mci%current_pass) if (pass%integral_defined) then error = abs (pass%error(it)) flag = error < error_goal else flag = .false. end if end associate else flag = .false. end if end function mci_vamp_error_reached module function mci_vamp_rel_error_reached (mci, it) result (flag) class(mci_vamp_t), intent(in) :: mci integer, intent(in) :: it logical :: flag real(default) :: rel_error_goal, rel_error rel_error_goal = mci%grid_par%rel_error_goal if (rel_error_goal > 0) then associate (pass => mci%current_pass) if (pass%integral_defined) then if (pass%integral(it) /= 0) then rel_error = abs (pass%error(it) / pass%integral(it)) flag = rel_error < rel_error_goal else flag = .true. end if else flag = .false. end if end associate else flag = .false. end if end function mci_vamp_rel_error_reached module function mci_vamp_accuracy_reached (mci, it) result (flag) class(mci_vamp_t), intent(in) :: mci integer, intent(in) :: it logical :: flag real(default) :: accuracy_goal, accuracy accuracy_goal = mci%grid_par%accuracy_goal if (accuracy_goal > 0) then associate (pass => mci%current_pass) if (pass%integral_defined) then if (pass%integral(it) /= 0) then accuracy = abs (pass%error(it) / pass%integral(it)) & * sqrt (real (pass%calls(it), default)) flag = accuracy < accuracy_goal else flag = .true. end if else flag = .false. end if end associate else flag = .false. end if end function mci_vamp_accuracy_reached @ %def mci_vamp_error_reached @ %def mci_vamp_rel_error_reached @ %def mci_vamp_accuracy_reached @ Prepare an event generation pass. Should be called before a sequence of events is generated, then we should call the corresponding finalizer. The pass-specific data of the previous integration pass are retained, but we reset the number of iterations and calls to zero. The latter now counts the number of events (calls to the sampling function, actually). <>= procedure :: prepare_simulation => mci_vamp_prepare_simulation <>= module subroutine mci_vamp_prepare_simulation (mci) class(mci_vamp_t), intent(inout) :: mci end subroutine mci_vamp_prepare_simulation <>= module subroutine mci_vamp_prepare_simulation (mci) class(mci_vamp_t), intent(inout) :: mci logical :: success if (mci%grid_filename_set) then call mci%read_grids_header (success) call mci%compute_md5sum () if (.not. success) then call msg_fatal ("Simulate: " & // "reading integration grids from file '" & // char (mci%grid_filename) // "' failed") end if else call msg_bug ("VAMP: simulation: no grids, no grid filename") end if end subroutine mci_vamp_prepare_simulation @ %def mci_vamp_prepare_simulation -@ +@ \subsection{Sampling function} The VAMP sampling function has a well-defined interface which we have to implement. The [[data]] argument allows us to pass pointers to the [[sampler]] and [[instance]] objects, so we can access configuration data and fill point-dependent contents within these objects. The [[weights]] and [[channel]] argument must be present in the call. Note: this is the place where we must look for external signals, i.e., interrupt from the OS. We would like to raise a \vamp\ exception which is then caught by [[vamp_sample_grids]] as the caller, so it dumps its current state and returns (with the signal still pending). \whizard\ will then terminate gracefully. Of course, VAMP should be able to resume from the dump. In the current implementation, we handle the exception in place and terminate immediately. The incomplete current integration pass is lost. <>= function vamp_sampling_function & (xi, data, weights, channel, grids) result (f) real(default) :: f real(default), dimension(:), intent(in) :: xi class(vamp_data_t), intent(in) :: data real(default), dimension(:), intent(in), optional :: weights integer, intent(in), optional :: channel type(vamp_grid), dimension(:), intent(in), optional :: grids type(exception) :: exc logical :: verbose character(*), parameter :: FN = "WHIZARD sampling function" class(mci_instance_t), pointer :: instance select type (data) type is (mci_workspace_t) instance => data%instance select type (instance) class is (mci_vamp_instance_t) verbose = instance%mci%verbose call instance%evaluate (data%sampler, channel, xi) if (signal_is_pending ()) then call raise_exception (exc, EXC_FATAL, FN, "signal received") call handle_vamp_exception (exc, verbose) call terminate_now_if_signal () end if instance%calls = instance%calls + 1 if (data%sampler%is_valid ()) & & instance%calls_valid = instance%calls_valid + 1 f = instance%get_value () call terminate_now_if_single_event () class default call msg_bug("VAMP: " // FN // ": unknown MCI instance type") end select end select end function vamp_sampling_function @ %def vamp_sampling_function @ This is supposed to be the mapping between integration channels. The VAMP event generating procedures technically require it, but it is meaningless in our setup where all transformations happen inside the sampler object. So, this implementation is trivial: Gfortran 7/8/9 bug, has to remain in the main module: <>= pure function phi_trivial (xi, channel_dummy) result (x) real(default), dimension(:), intent(in) :: xi integer, intent(in) :: channel_dummy real(default), dimension(size(xi)) :: x x = xi end function phi_trivial @ %def phi_trivial @ Generate weighted event. Note that the event weight ([[vamp_weight]]) is not just the MCI weight. [[vamp_next_event]] selects a channel based on the channel weights multiplied by the (previously recorded) maximum integrand value of the channel. The MCI weight is renormalized accordingly, to cancel this effect on the result. Gfortran 7/8/9/ bug, has to remain in the main module: <>= procedure :: generate_weighted_event => mci_vamp_generate_weighted_event <>= subroutine mci_vamp_generate_weighted_event (mci, instance, sampler) class(mci_vamp_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler class(vamp_data_t), allocatable :: data type(exception) :: vamp_exception select type (instance) type is (mci_vamp_instance_t) instance%vamp_weight_set = .false. allocate (mci_workspace_t :: data) select type (data) type is (mci_workspace_t) data%sampler => sampler data%instance => instance end select select type (rng => mci%rng) type is (rng_tao_t) if (instance%grids_defined) then call vamp_next_event ( & instance%vamp_x, & rng%state, & instance%grids, & vamp_sampling_function, & data, & phi = phi_trivial, & weight = instance%vamp_weight, & exc = vamp_exception) call handle_vamp_exception (vamp_exception, mci%verbose) instance%vamp_excess = 0 instance%vamp_weight_set = .true. else call msg_bug ("VAMP: generate event: grids undefined") end if class default call msg_fatal ("VAMP event generation: & &random-number generator must be TAO") end select end select end subroutine mci_vamp_generate_weighted_event @ %def mci_vamp_generate_weighted_event @ Generate unweighted event. Gfortran 7/8/9 bug, has to remain in the main module: <>= procedure :: generate_unweighted_event => & mci_vamp_generate_unweighted_event <>= subroutine mci_vamp_generate_unweighted_event & (mci, instance, sampler) class(mci_vamp_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler class(vamp_data_t), allocatable :: data logical :: positive type(exception) :: vamp_exception select type (instance) type is (mci_vamp_instance_t) instance%vamp_weight_set = .false. allocate (mci_workspace_t :: data) select type (data) type is (mci_workspace_t) data%sampler => sampler data%instance => instance end select select type (rng => mci%rng) type is (rng_tao_t) if (instance%grids_defined) then REJECTION: do call vamp_next_event ( & instance%vamp_x, & rng%state, & instance%grids, & vamp_sampling_function, & data, & phi = phi_trivial, & excess = instance%vamp_excess, & positive = positive, & exc = vamp_exception) if (signal_is_pending ()) return if (sampler%is_valid ()) exit REJECTION end do REJECTION call handle_vamp_exception (vamp_exception, mci%verbose) if (positive) then instance%vamp_weight = 1 else if (instance%negative_weights) then instance%vamp_weight = -1 else call msg_fatal ("VAMP: event with negative weight generated") instance%vamp_weight = 0 end if instance%vamp_weight_set = .true. else call msg_bug ("VAMP: generate event: grids undefined") end if class default call msg_fatal ("VAMP event generation: & &random-number generator must be TAO") end select end select end subroutine mci_vamp_generate_unweighted_event @ %def mci_vamp_generate_unweighted_event @ Rebuild an event, using the [[state]] input. Note: This feature is currently unused. <>= procedure :: rebuild_event => mci_vamp_rebuild_event <>= module subroutine mci_vamp_rebuild_event (mci, instance, sampler, state) class(mci_vamp_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state end subroutine mci_vamp_rebuild_event <>= module subroutine mci_vamp_rebuild_event (mci, instance, sampler, state) class(mci_vamp_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state call msg_bug ("MCI vamp rebuild event not implemented yet") end subroutine mci_vamp_rebuild_event @ %def mci_vamp_rebuild_event @ Pacify: override the default no-op, since VAMP numerics might need some massage. <>= procedure :: pacify => mci_vamp_pacify <>= module subroutine mci_vamp_pacify (object, efficiency_reset, error_reset) class(mci_vamp_t), intent(inout) :: object logical, intent(in), optional :: efficiency_reset, error_reset end subroutine mci_vamp_pacify <>= module subroutine mci_vamp_pacify (object, efficiency_reset, error_reset) class(mci_vamp_t), intent(inout) :: object logical, intent(in), optional :: efficiency_reset, error_reset logical :: err_reset type(pass_t), pointer :: current_pass err_reset = .false. if (present (error_reset)) err_reset = error_reset current_pass => object%first_pass do while (associated (current_pass)) if (allocated (current_pass%error) .and. err_reset) then current_pass%error = 0 end if if (allocated (current_pass%efficiency) .and. err_reset) then current_pass%efficiency = 1 end if current_pass => current_pass%next end do end subroutine mci_vamp_pacify @ %def mci_vamp_pacify @ \subsection{Sampler as Workspace} In the full setup, the sampling function requires the process instance object as workspace. We implement this by (i) implementing the process instance as a type extension of the abstract [[sampler_t]] object used by the MCI implementation and (ii) providing such an object as an extra argument to the sampling function that VAMP can call. To minimize cross-package dependencies, we use an abstract type [[vamp_workspace]] that VAMP declares and extend this by including a pointer to the [[sampler]] and [[instance]] objects. In the body of the sampling function, we dereference this pointer and can then work with the contents. <>= type, extends (vamp_data_t) :: mci_workspace_t class(mci_sampler_t), pointer :: sampler => null () class(mci_vamp_instance_t), pointer :: instance => null () end type mci_workspace_t @ %def mci_workspace_t @ \subsection{Integrator instance} The history entries should point to the corresponding history entry in the [[pass_t]] object. If there is none, we may allocate a local history, which is then just transient. <>= public :: mci_vamp_instance_t <>= type, extends (mci_instance_t) :: mci_vamp_instance_t type(mci_vamp_t), pointer :: mci => null () logical :: grids_defined = .false. logical :: grids_from_file = .false. integer :: n_it = 0 integer :: it = 0 logical :: pass_complete = .false. integer :: n_calls = 0 integer :: calls = 0 integer :: calls_valid = 0 logical :: it_complete = .false. logical :: enable_adapt_grids = .false. logical :: enable_adapt_weights = .false. logical :: allow_adapt_grids = .false. logical :: allow_adapt_weights = .false. integer :: n_adapt_grids = 0 integer :: n_adapt_weights = 0 logical :: generating_events = .false. real(default) :: safety_factor = 1 type(vamp_grids) :: grids real(default) :: g = 0 real(default), dimension(:), allocatable :: gi real(default) :: integral = 0 real(default) :: error = 0 real(default) :: efficiency = 0 real(default), dimension(:), allocatable :: vamp_x logical :: vamp_weight_set = .false. real(default) :: vamp_weight = 0 real(default) :: vamp_excess = 0 logical :: allocate_global_history = .false. type(vamp_history), dimension(:), pointer :: v_history => null () logical :: allocate_channel_history = .false. type(vamp_history), dimension(:,:), pointer :: v_histories => null () contains <> end type mci_vamp_instance_t @ %def mci_vamp_instance_t @ Output. <>= procedure :: write => mci_vamp_instance_write <>= module subroutine mci_vamp_instance_write (object, unit, pacify) class(mci_vamp_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify end subroutine mci_vamp_instance_write <>= module subroutine mci_vamp_instance_write (object, unit, pacify) class(mci_vamp_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify integer :: u, i character(len=7) :: fmt call pac_fmt (fmt, FMT_17, FMT_14, pacify) u = given_output_unit (unit) write (u, "(3x,A," // FMT_19 // ")") "Integrand = ", object%integrand write (u, "(3x,A," // FMT_19 // ")") "Weight = ", object%mci_weight if (object%vamp_weight_set) then write (u, "(3x,A," // FMT_19 // ")") "VAMP wgt = ", object%vamp_weight if (object%vamp_excess /= 0) then write (u, "(3x,A," // FMT_19 // ")") "VAMP exc = ", & object%vamp_excess end if end if write (u, "(3x,A,L1)") "adapt grids = ", object%enable_adapt_grids write (u, "(3x,A,L1)") "adapt weights = ", object%enable_adapt_weights if (object%grids_defined) then if (object%grids_from_file) then write (u, "(3x,A)") "VAMP grids: read from file" else write (u, "(3x,A)") "VAMP grids: defined" end if else write (u, "(3x,A)") "VAMP grids: [undefined]" end if write (u, "(3x,A,I0)") "n_it = ", object%n_it write (u, "(3x,A,I0)") "it = ", object%it write (u, "(3x,A,L1)") "pass complete = ", object%it_complete write (u, "(3x,A,I0)") "n_calls = ", object%n_calls write (u, "(3x,A,I0)") "calls = ", object%calls write (u, "(3x,A,I0)") "calls_valid = ", object%calls_valid write (u, "(3x,A,L1)") "it complete = ", object%it_complete write (u, "(3x,A,I0)") "n adapt.(g) = ", object%n_adapt_grids write (u, "(3x,A,I0)") "n adapt.(w) = ", object%n_adapt_weights write (u, "(3x,A,L1)") "gen. events = ", object%generating_events write (u, "(3x,A,L1)") "neg. weights = ", object%negative_weights if (object%safety_factor /= 1) write & (u, "(3x,A," // fmt // ")") "safety f = ", object%safety_factor write (u, "(3x,A," // fmt // ")") "integral = ", object%integral write (u, "(3x,A," // fmt // ")") "error = ", object%error write (u, "(3x,A," // fmt // ")") "eff. = ", object%efficiency write (u, "(3x,A)") "weights:" do i = 1, size (object%w) write (u, "(5x,I0,1x," // FMT_12 // ")") i, object%w(i) end do end subroutine mci_vamp_instance_write @ %def mci_vamp_instance_write @ Write the grids to the specified unit. <>= procedure :: write_grids => mci_vamp_instance_write_grids <>= module subroutine mci_vamp_instance_write_grids (object, unit) class(mci_vamp_instance_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine mci_vamp_instance_write_grids <>= module subroutine mci_vamp_instance_write_grids (object, unit) class(mci_vamp_instance_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (object%grids_defined) then call vamp_write_grids (object%grids, u, write_integrals = .true.) end if end subroutine mci_vamp_instance_write_grids @ %def mci_vamp_instance_write_grids @ Finalizer: the history arrays are pointer arrays and need finalization. <>= procedure :: final => mci_vamp_instance_final <>= module subroutine mci_vamp_instance_final (object) class(mci_vamp_instance_t), intent(inout) :: object end subroutine mci_vamp_instance_final <>= module subroutine mci_vamp_instance_final (object) class(mci_vamp_instance_t), intent(inout) :: object if (object%allocate_global_history) then if (associated (object%v_history)) then call vamp_delete_history (object%v_history) deallocate (object%v_history) end if end if if (object%allocate_channel_history) then if (associated (object%v_histories)) then call vamp_delete_history (object%v_histories) deallocate (object%v_histories) end if end if if (object%grids_defined) then call vamp_delete_grids (object%grids) object%grids_defined = .false. end if end subroutine mci_vamp_instance_final @ %def mci_vamp_instance_final @ Initializer. <>= procedure :: init => mci_vamp_instance_init <>= module subroutine mci_vamp_instance_init (mci_instance, mci) class(mci_vamp_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci end subroutine mci_vamp_instance_init <>= module subroutine mci_vamp_instance_init (mci_instance, mci) class(mci_vamp_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci call mci_instance%base_init (mci) select type (mci) type is (mci_vamp_t) mci_instance%mci => mci allocate (mci_instance%gi (mci%n_channel)) mci_instance%allocate_global_history = .not. mci%history_par%global mci_instance%allocate_channel_history = .not. mci%history_par%channel mci_instance%negative_weights = mci%negative_weights end select end subroutine mci_vamp_instance_init @ %def mci_vamp_instance_init @ Prepare a new integration pass: write the pass-specific settings to the [[instance]] object. This should be called initially, together with the [[create_grids]] procedure, and whenever we start a new integration pass. Set [[reshape]] if the number of calls is different than previously (unless it was zero, indicating the first pass). We link VAMP histories to the allocated histories in the current pass object, so the recorded results are persistent. However, if there are no histories present there, we allocate them locally. In that case, the histories will disappear together with the MCI instance object. <>= procedure :: new_pass => mci_vamp_instance_new_pass <>= module subroutine mci_vamp_instance_new_pass (instance, reshape) class(mci_vamp_instance_t), intent(inout) :: instance logical, intent(out) :: reshape end subroutine mci_vamp_instance_new_pass <>= module subroutine mci_vamp_instance_new_pass (instance, reshape) class(mci_vamp_instance_t), intent(inout) :: instance logical, intent(out) :: reshape type(pass_t), pointer :: current associate (mci => instance%mci) current => mci%current_pass instance%n_it = current%n_it if (instance%n_calls == 0) then reshape = .false. instance%n_calls = current%n_calls else if (instance%n_calls == current%n_calls) then reshape = .false. else reshape = .true. instance%n_calls = current%n_calls end if instance%it = 0 instance%calls = 0 instance%calls_valid = 0 instance%enable_adapt_grids = current%adapt_grids instance%enable_adapt_weights = current%adapt_weights instance%generating_events = .false. if (instance%allocate_global_history) then if (associated (instance%v_history)) then call vamp_delete_history (instance%v_history) deallocate (instance%v_history) end if allocate (instance%v_history (instance%n_it)) call vamp_create_history (instance%v_history, verbose = .false.) else instance%v_history => current%v_history end if if (instance%allocate_channel_history) then if (associated (instance%v_histories)) then call vamp_delete_history (instance%v_histories) deallocate (instance%v_histories) end if allocate (instance%v_histories (instance%n_it, mci%n_channel)) call vamp_create_history (instance%v_histories, verbose = .false.) else instance%v_histories => current%v_histories end if end associate end subroutine mci_vamp_instance_new_pass @ %def mci_vamp_instance_new_pass @ Create a grid set within the [[instance]] object, using the data of the current integration pass. Also reset counters that track this grid set. <>= procedure :: create_grids => mci_vamp_instance_create_grids <>= module subroutine mci_vamp_instance_create_grids (instance) class(mci_vamp_instance_t), intent(inout) :: instance end subroutine mci_vamp_instance_create_grids <>= module subroutine mci_vamp_instance_create_grids (instance) class(mci_vamp_instance_t), intent(inout) :: instance type (pass_t), pointer :: current integer, dimension(:), allocatable :: num_div real(default), dimension(:,:), allocatable :: region associate (mci => instance%mci) current => mci%current_pass allocate (num_div (mci%n_dim)) allocate (region (2, mci%n_dim)) region(1,:) = 0 region(2,:) = 1 num_div = current%n_bins instance%n_adapt_grids = 0 instance%n_adapt_weights = 0 if (.not. instance%grids_defined) then call vamp_create_grids (instance%grids, & region, & current%n_calls, & weights = instance%w, & num_div = num_div, & stratified = mci%grid_par%stratified) instance%grids_defined = .true. else call msg_bug ("VAMP: create grids: grids already defined") end if end associate end subroutine mci_vamp_instance_create_grids @ %def mci_vamp_instance_create_grids @ Reset a grid set, so we can start a fresh integration pass. In effect, we delete results of previous integrations, but keep the grid shapes, weights, and variance arrays, so adaptation is still possible. The grids are prepared for a specific number of calls (per iteration) and sampling mode (stratified/importance). The [[vamp_discard_integrals]] implementation will reshape the grids only if the argument [[num_calls]] is present. <>= procedure :: discard_integrals => mci_vamp_instance_discard_integrals <>= module subroutine mci_vamp_instance_discard_integrals (instance, reshape) class(mci_vamp_instance_t), intent(inout) :: instance logical, intent(in) :: reshape end subroutine mci_vamp_instance_discard_integrals <>= module subroutine mci_vamp_instance_discard_integrals (instance, reshape) class(mci_vamp_instance_t), intent(inout) :: instance logical, intent(in) :: reshape instance%calls = 0 instance%calls_valid = 0 instance%integral = 0 instance%error = 0 instance%efficiency = 0 associate (mci => instance%mci) if (instance%grids_defined) then if (mci%grid_par%use_vamp_equivalences) then if (reshape) then call vamp_discard_integrals (instance%grids, & num_calls = instance%n_calls, & stratified = mci%grid_par%stratified, & eq = mci%equivalences) else call vamp_discard_integrals (instance%grids, & stratified = mci%grid_par%stratified, & eq = mci%equivalences) end if else if (reshape) then call vamp_discard_integrals (instance%grids, & num_calls = instance%n_calls, & stratified = mci%grid_par%stratified) else call vamp_discard_integrals (instance%grids, & stratified = mci%grid_par%stratified) end if end if else call msg_bug ("VAMP: discard integrals: grids undefined") end if end associate end subroutine mci_vamp_instance_discard_integrals @ %def mci_vamp_instance_discard_integrals @ After grids are created (with equidistant binning and equal weight), adaptation is redundant. Therefore, we should allow it only after a complete integration step has been performed, calling this. <>= procedure :: allow_adaptation => mci_vamp_instance_allow_adaptation <>= module subroutine mci_vamp_instance_allow_adaptation (instance) class(mci_vamp_instance_t), intent(inout) :: instance end subroutine mci_vamp_instance_allow_adaptation <>= module subroutine mci_vamp_instance_allow_adaptation (instance) class(mci_vamp_instance_t), intent(inout) :: instance instance%allow_adapt_grids = .true. instance%allow_adapt_weights = .true. end subroutine mci_vamp_instance_allow_adaptation @ %def mci_vamp_instance_allow_adaptation @ Adapt grids. <>= procedure :: adapt_grids => mci_vamp_instance_adapt_grids <>= module subroutine mci_vamp_instance_adapt_grids (instance) class(mci_vamp_instance_t), intent(inout) :: instance end subroutine mci_vamp_instance_adapt_grids <>= module subroutine mci_vamp_instance_adapt_grids (instance) class(mci_vamp_instance_t), intent(inout) :: instance if (instance%enable_adapt_grids .and. instance%allow_adapt_grids) then if (instance%grids_defined) then call vamp_refine_grids (instance%grids) instance%n_adapt_grids = instance%n_adapt_grids + 1 else call msg_bug ("VAMP: adapt grids: grids undefined") end if end if end subroutine mci_vamp_instance_adapt_grids @ %def mci_vamp_instance_adapt_grids @ Adapt weights. Use the variance array returned by \vamp\ for recalculating the weight array. The parameter [[channel_weights_power]] dampens fluctuations. If the number of calls in a given channel falls below a user-defined threshold, the weight is not lowered further but kept at this threshold. The other channel weights are reduced accordingly. Gfortran 7/8/9 bug, has to remain in the main module: <>= procedure :: adapt_weights => mci_vamp_instance_adapt_weights <>= subroutine mci_vamp_instance_adapt_weights (instance) class(mci_vamp_instance_t), intent(inout) :: instance real(default) :: w_sum, w_avg_ch, sum_w_underflow, w_min real(default), dimension(:), allocatable :: weights integer :: n_ch, ch, n_underflow logical, dimension(:), allocatable :: mask, underflow type(exception) :: vamp_exception logical :: wsum_non_zero if (instance%enable_adapt_weights .and. instance%allow_adapt_weights) then associate (mci => instance%mci) if (instance%grids_defined) then allocate (weights (size (instance%grids%weights))) weights = instance%grids%weights & * vamp_get_variance (instance%grids%grids) & ** mci%grid_par%channel_weights_power w_sum = sum (weights) if (w_sum /= 0) then weights = weights / w_sum if (mci%n_chain /= 0) then allocate (mask (mci%n_channel)) do ch = 1, mci%n_chain mask = mci%chain == ch n_ch = count (mask) if (n_ch /= 0) then w_avg_ch = sum (weights, mask) / n_ch where (mask) weights = w_avg_ch end if end do end if if (mci%grid_par%threshold_calls /= 0) then w_min = & real (mci%grid_par%threshold_calls, default) & / instance%n_calls allocate (underflow (mci%n_channel)) underflow = weights /= 0 .and. abs (weights) < w_min n_underflow = count (underflow) sum_w_underflow = sum (weights, mask=underflow) if (sum_w_underflow /= 1) then where (underflow) weights = w_min elsewhere weights = weights & * (1 - n_underflow * w_min) / (1 - sum_w_underflow) end where end if end if end if call instance%set_channel_weights (weights, wsum_non_zero) if (wsum_non_zero) call vamp_update_weights & (instance%grids, weights, exc = vamp_exception) call handle_vamp_exception (vamp_exception, mci%verbose) else call msg_bug ("VAMP: adapt weights: grids undefined") end if end associate instance%n_adapt_weights = instance%n_adapt_weights + 1 end if end subroutine mci_vamp_instance_adapt_weights @ %def mci_vamp_instance_adapt_weights @ Integration: sample the VAMP grids. The number of calls etc. are already stored inside the grids. We provide the random-number generator, the sampling function, and a link to the workspace object, which happens to contain a pointer to the sampler object. The sampler object thus becomes the workspace of the sampling function. Note: in the current implementation, the random-number generator must be the TAO generator. This explicit dependence should be removed from the VAMP implementation. Gfortran 7/8/9 bug, has to remain in the main module: <>= procedure :: sample_grids => mci_vamp_instance_sample_grids <>= subroutine mci_vamp_instance_sample_grids & (instance, rng, sampler, eq) class(mci_vamp_instance_t), intent(inout), target :: instance class(rng_t), intent(inout) :: rng class(mci_sampler_t), intent(inout), target :: sampler type(vamp_equivalences_t), intent(in), optional :: eq class(vamp_data_t), allocatable :: data type(exception) :: vamp_exception allocate (mci_workspace_t :: data) select type (data) type is (mci_workspace_t) data%sampler => sampler data%instance => instance end select select type (rng) type is (rng_tao_t) instance%it = instance%it + 1 instance%calls = 0 if (instance%grids_defined) then call vamp_sample_grids ( & rng%state, & instance%grids, & vamp_sampling_function, & data, & 1, & eq = eq, & history = instance%v_history(instance%it:), & histories = instance%v_histories(instance%it:,:), & integral = instance%integral, & std_dev = instance%error, & exc = vamp_exception, & negative_weights = instance%negative_weights) call handle_vamp_exception (vamp_exception, instance%mci%verbose) instance%efficiency = instance%get_efficiency () else call msg_bug ("VAMP: sample grids: grids undefined") end if class default call msg_fatal ("VAMP integration: random-number generator must be TAO") end select end subroutine mci_vamp_instance_sample_grids @ %def mci_vamp_instance_sample_grids @ Compute the reweighting efficiency for the current grids, suitable averaged over all active channels. <>= procedure :: get_efficiency_array => mci_vamp_instance_get_efficiency_array procedure :: get_efficiency => mci_vamp_instance_get_efficiency <>= module function mci_vamp_instance_get_efficiency_array & (mci) result (efficiency) class(mci_vamp_instance_t), intent(in) :: mci real(default), dimension(:), allocatable :: efficiency end function mci_vamp_instance_get_efficiency_array module function mci_vamp_instance_get_efficiency (mci) result (efficiency) class(mci_vamp_instance_t), intent(in) :: mci real(default) :: efficiency end function mci_vamp_instance_get_efficiency <>= module function mci_vamp_instance_get_efficiency_array & (mci) result (efficiency) class(mci_vamp_instance_t), intent(in) :: mci real(default), dimension(:), allocatable :: efficiency allocate (efficiency (mci%mci%n_channel)) if (.not. mci%negative_weights) then where (mci%grids%grids%f_max /= 0) efficiency = mci%grids%grids%mu(1) / abs (mci%grids%grids%f_max) elsewhere efficiency = 0 end where else where (mci%grids%grids%f_max /= 0) efficiency = & (mci%grids%grids%mu_plus(1) - mci%grids%grids%mu_minus(1)) & / abs (mci%grids%grids%f_max) elsewhere efficiency = 0 end where end if end function mci_vamp_instance_get_efficiency_array module function mci_vamp_instance_get_efficiency (mci) result (efficiency) class(mci_vamp_instance_t), intent(in) :: mci real(default) :: efficiency real(default), dimension(:), allocatable :: weight real(default) :: norm allocate (weight (mci%mci%n_channel)) weight = mci%grids%weights * abs (mci%grids%grids%f_max) norm = sum (weight) if (norm /= 0) then efficiency = dot_product (mci%get_efficiency_array (), weight) / norm else efficiency = 1 end if end function mci_vamp_instance_get_efficiency @ %def mci_vamp_instance_get_efficiency_array @ %def mci_vamp_instance_get_efficiency @ Prepare an event generation pass. Should be called before a sequence of events is generated, then we should call the corresponding finalizer. The pass-specific data of the previous integration pass are retained, but we reset the number of iterations and calls to zero. The latter now counts the number of events (calls to the sampling function, actually). <>= procedure :: init_simulation => mci_vamp_instance_init_simulation <>= module subroutine mci_vamp_instance_init_simulation & (instance, safety_factor) class(mci_vamp_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor end subroutine mci_vamp_instance_init_simulation <>= module subroutine mci_vamp_instance_init_simulation & (instance, safety_factor) class(mci_vamp_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor associate (mci => instance%mci) allocate (instance%vamp_x (mci%n_dim)) instance%it = 0 instance%calls = 0 instance%generating_events = .true. if (present (safety_factor)) instance%safety_factor = safety_factor if (.not. instance%grids_defined) then if (mci%grid_filename_set) then if (.not. mci%check_grid_file) & call msg_warning ("Reading grid file: MD5 sum check disabled") call msg_message ("Simulate: " & // "using integration grids from file '" & // char (mci%grid_filename) // "'") call mci%read_grids_data (instance) if (instance%safety_factor /= 1) then write (msg_buffer, "(A,ES10.3,A)") "Simulate: & &applying safety factor", instance%safety_factor, & " to event rejection" call msg_message () instance%grids%grids%f_max = & instance%grids%grids%f_max * instance%safety_factor end if else call msg_bug ("VAMP: simulation: no grids, no grid filename") end if end if end associate end subroutine mci_vamp_instance_init_simulation @ %def mci_vamp_init_simulation @ Finalize an event generation pass. Should be called before a sequence of events is generated, then we should call the corresponding finalizer. <>= procedure :: final_simulation => mci_vamp_instance_final_simulation <>= module subroutine mci_vamp_instance_final_simulation (instance) class(mci_vamp_instance_t), intent(inout) :: instance end subroutine mci_vamp_instance_final_simulation <>= module subroutine mci_vamp_instance_final_simulation (instance) class(mci_vamp_instance_t), intent(inout) :: instance if (allocated (instance%vamp_x)) deallocate (instance%vamp_x) end subroutine mci_vamp_instance_final_simulation @ %def mci_vamp_instance_final_simulation @ \subsection{Integrator instance: evaluation} Here, we compute the multi-channel reweighting factor for the current channel, that accounts for the Jacobians of the transformations from/to all other channels. The computation of the VAMP probabilities may consume considerable time, therefore we enable parallel evaluation. (Collecting the contributions to [[mci%g]] is a reduction, which we should also implement via OpenMP.) <>= procedure :: compute_weight => mci_vamp_instance_compute_weight <>= module subroutine mci_vamp_instance_compute_weight (mci, c) class(mci_vamp_instance_t), intent(inout) :: mci integer, intent(in) :: c end subroutine mci_vamp_instance_compute_weight <>= module subroutine mci_vamp_instance_compute_weight (mci, c) class(mci_vamp_instance_t), intent(inout) :: mci integer, intent(in) :: c integer :: i mci%selected_channel = c !$OMP PARALLEL PRIVATE(i) SHARED(mci) !$OMP DO do i = 1, mci%mci%n_channel if (mci%w(i) /= 0) then mci%gi(i) = vamp_probability (mci%grids%grids(i), mci%x(:,i)) else mci%gi(i) = 0 end if end do !$OMP END DO !$OMP END PARALLEL mci%g = 0 if (mci%gi(c) /= 0) then do i = 1, mci%mci%n_channel if (mci%w(i) /= 0 .and. mci%f(i) /= 0) then mci%g = mci%g + mci%w(i) * mci%gi(i) / mci%f(i) end if end do end if if (mci%g /= 0) then mci%mci_weight = mci%gi(c) / mci%g else mci%mci_weight = 0 end if end subroutine mci_vamp_instance_compute_weight @ %def mci_vamp_instance_compute_weight @ Record the integrand. <>= procedure :: record_integrand => mci_vamp_instance_record_integrand <>= module subroutine mci_vamp_instance_record_integrand (mci, integrand) class(mci_vamp_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand end subroutine mci_vamp_instance_record_integrand <>= module subroutine mci_vamp_instance_record_integrand (mci, integrand) class(mci_vamp_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand mci%integrand = integrand end subroutine mci_vamp_instance_record_integrand @ %def mci_vamp_instance_record_integrand @ Get the event weight. The default routine returns the same value that we would use for integration. This is correct if we select the integration channel according to the channel weight. [[vamp_next_event]] does differently, so we should rather rely on the weight that VAMP returns. This is the value stored in [[vamp_weight]]. We override the default TBP accordingly. <>= procedure :: get_event_weight => mci_vamp_instance_get_event_weight procedure :: get_event_excess => mci_vamp_instance_get_event_excess <>= module function mci_vamp_instance_get_event_weight (mci) result (value) class(mci_vamp_instance_t), intent(in) :: mci real(default) :: value end function mci_vamp_instance_get_event_weight module function mci_vamp_instance_get_event_excess (mci) result (value) class(mci_vamp_instance_t), intent(in) :: mci real(default) :: value end function mci_vamp_instance_get_event_excess <>= module function mci_vamp_instance_get_event_weight (mci) result (value) class(mci_vamp_instance_t), intent(in) :: mci real(default) :: value if (mci%vamp_weight_set) then value = mci%vamp_weight else call msg_bug ("VAMP: attempt to read undefined event weight") end if end function mci_vamp_instance_get_event_weight module function mci_vamp_instance_get_event_excess (mci) result (value) class(mci_vamp_instance_t), intent(in) :: mci real(default) :: value if (mci%vamp_weight_set) then value = mci%vamp_excess else call msg_bug ("VAMP: attempt to read undefined event excess weight") end if end function mci_vamp_instance_get_event_excess @ %def mci_vamp_instance_get_event_excess @ \subsection{VAMP exceptions} A VAMP routine may have raised an exception. Turn this into a WHIZARD error message. An external signal could raise a fatal exception, but this should be delayed and handled by the correct termination routine. Gfortran 7/8/9 bug, has to remain in the main module: <>= subroutine handle_vamp_exception (exc, verbose) type(exception), intent(in) :: exc logical, intent(in) :: verbose integer :: exc_level if (verbose) then exc_level = EXC_INFO else exc_level = EXC_ERROR end if if (exc%level >= exc_level) then write (msg_buffer, "(A,':',1x,A)") trim (exc%origin), trim (exc%message) select case (exc%level) case (EXC_INFO); call msg_message () case (EXC_WARN); call msg_warning () case (EXC_ERROR); call msg_error () case (EXC_FATAL) if (signal_is_pending ()) then call msg_message () else call msg_fatal () end if end select end if end subroutine handle_vamp_exception @ %def handle_vamp_exception @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[mci_vamp_ut.f90]]>>= <> module mci_vamp_ut use unit_tests use mci_vamp_uti <> <> contains <> end module mci_vamp_ut @ %def mci_vamp_ut @ <<[[mci_vamp_uti.f90]]>>= <> module mci_vamp_uti <> <> use io_units use constants, only: PI, TWOPI use rng_base use rng_tao use phs_base use mci_base use vamp, only: vamp_write_grids !NODEP! use mci_vamp <> <> <> contains <> end module mci_vamp_uti @ %def mci_vamp_ut @ API: driver for the unit tests below. <>= public :: mci_vamp_test <>= subroutine mci_vamp_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine mci_vamp_test @ %def mci_vamp_test @ \subsubsection{Test sampler} A test sampler object should implement a function with known integral that we can use to check the integrator. In mode [[1]], the function is $f(x) = 3 x^2$ with integral $\int_0^1 f(x)\,dx=1$ and maximum $f(1)=3$. If the integration dimension is greater than one, the function is extended as a constant in the other dimension(s). In mode [[2]], the function is $11 x^{10}$, also with integral $1$. Mode [[4]] includes ranges of zero and negative function value, the integral is negative. The results should be identical to the results of [[mci_midpoint_4]], where the same function is evaluated. The function is $f(x) = (1 - 3 x^2)\,\theta(x-1/2)$ with integral $\int_0^1 f(x)\,dx=-3/8$, minimum $f(1)=-2$ and maximum $f(1/2)=1/4$. <>= type, extends (mci_sampler_t) :: test_sampler_1_t real(default), dimension(:), allocatable :: x real(default) :: val integer :: mode = 1 contains <> end type test_sampler_1_t @ %def test_sampler_1_t @ Output: There is nothing stored inside, so just print an informative line. <>= procedure :: write => test_sampler_1_write <>= subroutine test_sampler_1_write (object, unit, testflag) class(test_sampler_1_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) select case (object%mode) case (1) write (u, "(1x,A)") "Test sampler: f(x) = 3 x^2" case (2) write (u, "(1x,A)") "Test sampler: f(x) = 11 x^10" case (3) write (u, "(1x,A)") "Test sampler: f(x) = 11 x^10 * 2 * cos^2 (2 pi y)" case (4) write (u, "(1x,A)") "Test sampler: f(x) = (1 - 3 x^2) theta(x - 1/2)" end select end subroutine test_sampler_1_write @ %def test_sampler_1_write @ Evaluation: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure :: evaluate => test_sampler_1_evaluate <>= subroutine test_sampler_1_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_1_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f if (allocated (sampler%x)) deallocate (sampler%x) allocate (sampler%x (size (x_in))) sampler%x = x_in select case (sampler%mode) case (1) sampler%val = 3 * x_in(1) ** 2 case (2) sampler%val = 11 * x_in(1) ** 10 case (3) sampler%val = 11 * x_in(1) ** 10 * 2 * cos (twopi * x_in(2)) ** 2 case (4) if (x_in(1) >= .5_default) then sampler%val = 1 - 3 * x_in(1) ** 2 else sampler%val = 0 end if end select call sampler%fetch (val, x, f) end subroutine test_sampler_1_evaluate @ %def test_sampler_1_evaluate @ The point is always valid. <>= procedure :: is_valid => test_sampler_1_is_valid <>= function test_sampler_1_is_valid (sampler) result (valid) class(test_sampler_1_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_1_is_valid @ %def test_sampler_1_is_valid @ Rebuild: compute all but the function value. <>= procedure :: rebuild => test_sampler_1_rebuild <>= subroutine test_sampler_1_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_1_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f if (allocated (sampler%x)) deallocate (sampler%x) allocate (sampler%x (size (x_in))) sampler%x = x_in sampler%val = val x(:,1) = sampler%x f = 1 end subroutine test_sampler_1_rebuild @ %def test_sampler_1_rebuild @ Extract the results. <>= procedure :: fetch => test_sampler_1_fetch <>= subroutine test_sampler_1_fetch (sampler, val, x, f) class(test_sampler_1_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x(:,1) = sampler%x f = 1 end subroutine test_sampler_1_fetch @ %def test_sampler_1_fetch @ \subsubsection{Two-channel, two dimension test sampler} This sampler implements the function \begin{equation} f(x, y) = 4\sin^2(\pi x)\sin^2(\pi y) + 2\sin^2(\pi v) \end{equation} where \begin{align} x &= u^v &u &= xy \\ y &= u^{(1-v)} &v &= \frac12\left(1 + \frac{\log(x/y)}{\log xy}\right) \end{align} Each term contributes $1$ to the integral. The first term in the function is peaked along a cross aligned to the coordinates $x$ and $y$, while the second term is peaked along the diagonal $x=y$. The Jacobian is \begin{equation} \frac{\partial(x,y)}{\partial(u,v)} = |\log u| \end{equation} <>= type, extends (mci_sampler_t) :: test_sampler_2_t real(default), dimension(:,:), allocatable :: x real(default), dimension(:), allocatable :: f real(default) :: val contains <> end type test_sampler_2_t @ %def test_sampler_2_t @ Output: There is nothing stored inside, so just print an informative line. <>= procedure :: write => test_sampler_2_write <>= subroutine test_sampler_2_write (object, unit, testflag) class(test_sampler_2_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Two-channel test sampler 2" end subroutine test_sampler_2_write @ %def test_sampler_2_write @ Kinematics: compute $x$ and Jacobians, given the input parameter array. <>= procedure :: compute => test_sampler_2_compute <>= subroutine test_sampler_2_compute (sampler, c, x_in) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default) :: xx, yy, uu, vv if (.not. allocated (sampler%x)) & allocate (sampler%x (size (x_in), 2)) if (.not. allocated (sampler%f)) & allocate (sampler%f (2)) select case (c) case (1) xx = x_in(1) yy = x_in(2) uu = xx * yy vv = (1 + log (xx/yy) / log (xx*yy)) / 2 case (2) uu = x_in(1) vv = x_in(2) xx = uu ** vv yy = uu ** (1 - vv) end select sampler%val = (2 * sin (pi * xx) * sin (pi * yy)) ** 2 & + 2 * sin (pi * vv) ** 2 sampler%f(1) = 1 sampler%f(2) = abs (log (uu)) sampler%x(:,1) = [xx, yy] sampler%x(:,2) = [uu, vv] end subroutine test_sampler_2_compute @ %def test_sampler_kinematics @ Evaluation: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure :: evaluate => test_sampler_2_evaluate <>= subroutine test_sampler_2_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) call sampler%fetch (val, x, f) end subroutine test_sampler_2_evaluate @ %def test_sampler_2_evaluate @ The point is always valid. <>= procedure :: is_valid => test_sampler_2_is_valid <>= function test_sampler_2_is_valid (sampler) result (valid) class(test_sampler_2_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_2_is_valid @ %def test_sampler_2_is_valid @ Rebuild: compute all but the function value. <>= procedure :: rebuild => test_sampler_2_rebuild <>= subroutine test_sampler_2_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) x = sampler%x f = sampler%f end subroutine test_sampler_2_rebuild @ %def test_sampler_2_rebuild @ Extract the results. <>= procedure :: fetch => test_sampler_2_fetch <>= subroutine test_sampler_2_fetch (sampler, val, x, f) class(test_sampler_2_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x = sampler%x f = sampler%f end subroutine test_sampler_2_fetch @ %def test_sampler_2_fetch @ \subsubsection{Two-channel, one dimension test sampler} This sampler implements the function \begin{equation} f(x, y) = a * 5 x^4 + b * 5 (1-x)^4 \end{equation} Each term contributes $1$ to the integral, multiplied by $a$ or $b$, respectively. The first term is peaked at $x=1$, the second one at $x=0$.. We implement the two mappings \begin{equation} x = u^{1/5} \quad\text{and}\quad x = 1 - v^{1/5}, \end{equation} with Jacobians \begin{equation} \frac{\partial(x)}{\partial(u)} = u^{-4/5}/5 \quad\text{and}\quad v^{-4/5}/5, \end{equation} respectively. The first mapping concentrates points near $x=1$, the second one near $x=0$. <>= type, extends (mci_sampler_t) :: test_sampler_3_t real(default), dimension(:,:), allocatable :: x real(default), dimension(:), allocatable :: f real(default) :: val real(default) :: a = 1 real(default) :: b = 1 contains <> end type test_sampler_3_t @ %def test_sampler_3_t @ Output: display $a$ and $b$ <>= procedure :: write => test_sampler_3_write <>= subroutine test_sampler_3_write (object, unit, testflag) class(test_sampler_3_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Two-channel test sampler 3" write (u, "(3x,A,F5.2)") "a = ", object%a write (u, "(3x,A,F5.2)") "b = ", object%b end subroutine test_sampler_3_write @ %def test_sampler_3_write @ Kinematics: compute $x$ and Jacobians, given the input parameter array. <>= procedure :: compute => test_sampler_3_compute <>= subroutine test_sampler_3_compute (sampler, c, x_in) class(test_sampler_3_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default) :: u, v, xx if (.not. allocated (sampler%x)) & allocate (sampler%x (size (x_in), 2)) if (.not. allocated (sampler%f)) & allocate (sampler%f (2)) select case (c) case (1) u = x_in(1) xx = u ** 0.2_default v = (1 - xx) ** 5._default case (2) v = x_in(1) xx = 1 - v ** 0.2_default u = xx ** 5._default end select sampler%val = sampler%a * 5 * xx ** 4 + sampler%b * 5 * (1 - xx) ** 4 sampler%f(1) = 0.2_default * u ** (-0.8_default) sampler%f(2) = 0.2_default * v ** (-0.8_default) sampler%x(:,1) = [u] sampler%x(:,2) = [v] end subroutine test_sampler_3_compute @ %def test_sampler_kineamtics @ Evaluation: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure :: evaluate => test_sampler_3_evaluate <>= subroutine test_sampler_3_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_3_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) call sampler%fetch (val, x, f) end subroutine test_sampler_3_evaluate @ %def test_sampler_3_evaluate @ The point is always valid. <>= procedure :: is_valid => test_sampler_3_is_valid <>= function test_sampler_3_is_valid (sampler) result (valid) class(test_sampler_3_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_3_is_valid @ %def test_sampler_3_is_valid @ Rebuild: compute all but the function value. <>= procedure :: rebuild => test_sampler_3_rebuild <>= subroutine test_sampler_3_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_3_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) x = sampler%x f = sampler%f end subroutine test_sampler_3_rebuild @ %def test_sampler_3_rebuild @ Extract the results. <>= procedure :: fetch => test_sampler_3_fetch <>= subroutine test_sampler_3_fetch (sampler, val, x, f) class(test_sampler_3_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x = sampler%x f = sampler%f end subroutine test_sampler_3_fetch @ %def test_sampler_3_fetch @ \subsubsection{One-dimensional integration} Construct an integrator and use it for a one-dimensional sampler. Note: We would like to check the precise contents of the grid allocated during integration, but the output format for reals is very long (for good reasons), so the last digits in the grid content display are numerical noise. So, we just check the integration results. <>= call test (mci_vamp_1, "mci_vamp_1", & "one-dimensional integral", & u, results) <>= public :: mci_vamp_1 <>= subroutine mci_vamp_1 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_1" write (u, "(A)") "* Purpose: integrate function in one dimension & &(single channel)" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 1) select type (mci) type is (mci_vamp_t) grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_1_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_calls = 1000" write (u, "(A)") " (lower precision to avoid" write (u, "(A)") " numerical noise)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass () end select call mci%integrate (mci_instance, sampler, 1, 1000, pacify = .true.) call mci%write (u, .true.) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u, .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_1" end subroutine mci_vamp_1 @ %def mci_vamp_1 @ \subsubsection{Multiple iterations} Construct an integrator and use it for a one-dimensional sampler. Integrate with five iterations without grid adaptation. <>= call test (mci_vamp_2, "mci_vamp_2", & "multiple iterations", & u, results) <>= public :: mci_vamp_2 <>= subroutine mci_vamp_2 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_2" write (u, "(A)") "* Purpose: integrate function in one dimension & &(single channel)" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 1) select type (mci) type is (mci_vamp_t) grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_1_t :: sampler) select type (sampler) type is (test_sampler_1_t) sampler%mode = 2 end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 100" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .false.) end select call mci%integrate (mci_instance, sampler, 3, 100) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_2" end subroutine mci_vamp_2 @ %def mci_vamp_2 @ \subsubsection{Grid adaptation} Construct an integrator and use it for a one-dimensional sampler. Integrate with three iterations and in-between grid adaptations. <>= call test (mci_vamp_3, "mci_vamp_3", & "grid adaptation", & u, results) <>= public :: mci_vamp_3 <>= subroutine mci_vamp_3 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_3" write (u, "(A)") "* Purpose: integrate function in one dimension & &(single channel)" write (u, "(A)") "* and adapt grid" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 1) select type (mci) type is (mci_vamp_t) grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_1_t :: sampler) select type (sampler) type is (test_sampler_1_t) sampler%mode = 2 end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 100" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 3, 100) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_3" end subroutine mci_vamp_3 @ %def mci_vamp_3 @ \subsubsection{Two-dimensional integral} Construct an integrator and use it for a two-dimensional sampler. Integrate with three iterations and in-between grid adaptations. <>= call test (mci_vamp_4, "mci_vamp_4", & "two-dimensional integration", & u, results) <>= public :: mci_vamp_4 <>= subroutine mci_vamp_4 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_4" write (u, "(A)") "* Purpose: integrate function in two dimensions & &(single channel)" write (u, "(A)") "* and adapt grid" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 1) select type (mci) type is (mci_vamp_t) grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_1_t :: sampler) select type (sampler) type is (test_sampler_1_t) sampler%mode = 3 end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_4" end subroutine mci_vamp_4 @ %def mci_vamp_4 @ \subsubsection{Two-channel integral} Construct an integrator and use it for a two-dimensional sampler with two channels. Integrate with three iterations and in-between grid adaptations. <>= call test (mci_vamp_5, "mci_vamp_5", & "two-dimensional integration", & u, results) <>= public :: mci_vamp_5 <>= subroutine mci_vamp_5 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_5" write (u, "(A)") "* Purpose: integrate function in two dimensions & &(two channels)" write (u, "(A)") "* and adapt grid" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_2_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_5" end subroutine mci_vamp_5 @ %def mci_vamp_5 @ \subsubsection{Weight adaptation} Construct an integrator and use it for a one-dimensional sampler with two channels. Integrate with three iterations and in-between weight adaptations. <>= call test (mci_vamp_6, "mci_vamp_6", & "weight adaptation", & u, results) <>= public :: mci_vamp_6 <>= subroutine mci_vamp_6 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_6" write (u, "(A)") "* Purpose: integrate function in one dimension & &(two channels)" write (u, "(A)") "* and adapt weights" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_3_t :: sampler) select type (sampler) type is (test_sampler_3_t) sampler%a = 0.9_default sampler%b = 0.1_default end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_weights = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () deallocate (mci_instance) deallocate (mci) write (u, "(A)") write (u, "(A)") "* Re-initialize with chained channels" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 2) call mci%declare_chains ([1,1]) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_weights = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_6" end subroutine mci_vamp_6 @ %def mci_vamp_6 @ \subsubsection{Equivalences} Construct an integrator and use it for a one-dimensional sampler with two channels. Integrate with three iterations and in-between grid adaptations. Apply an equivalence between the two channels, so the binning of the two channels is forced to coincide. Compare this with the behavior without equivalences. <>= call test (mci_vamp_7, "mci_vamp_7", & "use channel equivalences", & u, results) <>= public :: mci_vamp_7 <>= subroutine mci_vamp_7 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler type(phs_channel_t), dimension(:), allocatable :: channel class(rng_t), allocatable :: rng real(default), dimension(:,:), allocatable :: x integer :: u_grid, iostat, i, div, ch character(16) :: buffer write (u, "(A)") "* Test output: mci_vamp_7" write (u, "(A)") "* Purpose: check effect of channel equivalences" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_3_t :: sampler) select type (sampler) type is (test_sampler_3_t) sampler%a = 0.7_default sampler%b = 0.3_default end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 2 and n_calls = 1000, & &adapt grids" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 2, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Write grids and extract binning" write (u, "(A)") u_grid = free_unit () open (u_grid, status = "scratch", action = "readwrite") select type (mci_instance) type is (mci_vamp_instance_t) call vamp_write_grids (mci_instance%grids, u_grid) end select rewind (u_grid) allocate (x (0:20, 2)) do div = 1, 2 FIND_BINS1: do read (u_grid, "(A)") buffer if (trim (adjustl (buffer)) == "begin d%x") then do read (u_grid, *, iostat = iostat) i, x(i,div) if (iostat /= 0) exit FIND_BINS1 end do end if end do FIND_BINS1 end do close (u_grid) write (u, "(1x,A,L1)") "Equal binning in both channels = ", & all (x(:,1) == x(:,2)) deallocate (x) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () deallocate (mci_instance) deallocate (mci) write (u, "(A)") write (u, "(A)") "* Re-initialize integrator, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .true. call mci%set_grid_parameters (grid_par) end select write (u, "(A)") "* Define equivalences" write (u, "(A)") allocate (channel (2)) do ch = 1, 2 allocate (channel(ch)%eq (2)) do i = 1, 2 associate (eq => channel(ch)%eq(i)) call eq%init (1) eq%c = i eq%perm = [1] eq%mode = [0] end associate end do write (u, "(1x,I0,':')", advance = "no") ch call channel(ch)%write (u) end do call mci%declare_equivalences (channel, dim_offset = 0) allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 2 and n_calls = 1000, & &adapt grids" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 2, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Write grids and extract binning" write (u, "(A)") u_grid = free_unit () open (u_grid, status = "scratch", action = "readwrite") select type (mci_instance) type is (mci_vamp_instance_t) call vamp_write_grids (mci_instance%grids, u_grid) end select rewind (u_grid) allocate (x (0:20, 2)) do div = 1, 2 FIND_BINS2: do read (u_grid, "(A)") buffer if (trim (adjustl (buffer)) == "begin d%x") then do read (u_grid, *, iostat = iostat) i, x(i,div) if (iostat /= 0) exit FIND_BINS2 end do end if end do FIND_BINS2 end do close (u_grid) write (u, "(1x,A,L1)") "Equal binning in both channels = ", & all (x(:,1) == x(:,2)) deallocate (x) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_7" end subroutine mci_vamp_7 @ %def mci_vamp_7 @ \subsubsection{Multiple passes} Integrate with three passes and different settings for weight and grid adaptation. <>= call test (mci_vamp_8, "mci_vamp_8", & "integration passes", & u, results) <>= public :: mci_vamp_8 <>= subroutine mci_vamp_8 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_8" write (u, "(A)") "* Purpose: integrate function in one dimension & &(two channels)" write (u, "(A)") "* in three passes" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_3_t :: sampler) select type (sampler) type is (test_sampler_3_t) sampler%a = 0.9_default sampler%b = 0.1_default end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with grid and weight adaptation" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true., adapt_weights = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with grid adaptation" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Integrate without adaptation" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass () end select call mci%integrate (mci_instance, sampler, 3, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_8" end subroutine mci_vamp_8 @ %def mci_vamp_8 @ \subsubsection{Weighted events} Construct an integrator and use it for a two-dimensional sampler with two channels. Integrate and generate a weighted event. <>= call test (mci_vamp_9, "mci_vamp_9", & "weighted event", & u, results) <>= public :: mci_vamp_9 <>= subroutine mci_vamp_9 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_9" write (u, "(A)") "* Purpose: integrate function in two dimensions & &(two channels)" write (u, "(A)") "* and generate a weighted event" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_2_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") call mci%add_pass () call mci%integrate (mci_instance, sampler, 1, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Generate a weighted event" write (u, "(A)") call mci_instance%init_simulation () call mci%generate_weighted_event (mci_instance, sampler) write (u, "(1x,A)") "MCI instance:" call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final_simulation () call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_9" end subroutine mci_vamp_9 @ %def mci_vamp_9 @ \subsubsection{Grids I/O} Construct an integrator and allocate grids. Write grids to file, read them in again and compare. <>= call test (mci_vamp_10, "mci_vamp_10", & "grids I/O", & u, results) <>= public :: mci_vamp_10 <>= subroutine mci_vamp_10 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng type(string_t) :: file1, file2 character(80) :: buffer1, buffer2 integer :: u1, u2, iostat1, iostat2 logical :: equal, success write (u, "(A)") "* Test output: mci_vamp_10" write (u, "(A)") "* Purpose: write and read VAMP grids" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) mci%md5sum = "1234567890abcdef1234567890abcdef" call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_2_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") call mci%add_pass () call mci%integrate (mci_instance, sampler, 1, 1000) write (u, "(A)") "* Write grids to file" write (u, "(A)") file1 = "mci_vamp_10.1" select type (mci) type is (mci_vamp_t) call mci%set_grid_filename (file1) call mci%write_grids (mci_instance) end select call mci_instance%final () call mci%final () deallocate (mci) write (u, "(A)") "* Read grids from file" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_vamp_t) call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) mci%md5sum = "1234567890abcdef1234567890abcdef" call mci%allocate_instance (mci_instance) call mci_instance%init (mci) select type (mci) type is (mci_vamp_t) call mci%set_grid_filename (file1) call mci%add_pass () call mci%current_pass%configure (1, 1000, & mci%min_calls, & mci%grid_par%min_bins, mci%grid_par%max_bins, & mci%grid_par%min_calls_per_channel * mci%n_channel) call mci%read_grids_header (success) call mci%compute_md5sum () call mci%read_grids_data (mci_instance, read_integrals = .true.) end select write (u, "(1x,A,L1)") "success = ", success write (u, "(A)") write (u, "(A)") "* Write grids again" write (u, "(A)") file2 = "mci_vamp_10.2" select type (mci) type is (mci_vamp_t) call mci%set_grid_filename (file2) call mci%write_grids (mci_instance) end select u1 = free_unit () open (u1, file = char (file1) // ".vg", action = "read", status = "old") u2 = free_unit () open (u2, file = char (file2) // ".vg", action = "read", status = "old") equal = .true. iostat1 = 0 iostat2 = 0 do while (equal .and. iostat1 == 0 .and. iostat2 == 0) read (u1, "(A)", iostat = iostat1) buffer1 read (u2, "(A)", iostat = iostat2) buffer2 equal = buffer1 == buffer2 .and. iostat1 == iostat2 end do close (u1) close (u2) if (equal) then write (u, "(1x,A)") "Success: grid files are identical" else write (u, "(1x,A)") "Failure: grid files differ" end if write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_10" end subroutine mci_vamp_10 @ %def mci_vamp_10 @ \subsubsection{Weighted events with grid I/O} Construct an integrator and use it for a two-dimensional sampler with two channels. Integrate, write grids, and generate a weighted event using the grids from file. <>= call test (mci_vamp_11, "mci_vamp_11", & "weighted events with grid I/O", & u, results) <>= public :: mci_vamp_11 <>= subroutine mci_vamp_11 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_11" write (u, "(A)") "* Purpose: integrate function in two dimensions & &(two channels)" write (u, "(A)") "* and generate a weighted event" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) call mci%set_grid_filename (var_str ("mci_vamp_11")) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_2_t :: sampler) write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") call mci%add_pass () call mci%integrate (mci_instance, sampler, 1, 1000) write (u, "(A)") "* Reset instance" write (u, "(A)") call mci_instance%final () call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Generate a weighted event" write (u, "(A)") call mci_instance%init_simulation () call mci%generate_weighted_event (mci_instance, sampler) write (u, "(A)") "* Cleanup" call mci_instance%final_simulation () call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_11" end subroutine mci_vamp_11 @ %def mci_vamp_11 @ \subsubsection{Unweighted events with grid I/O} Construct an integrator and use it for a two-dimensional sampler with two channels. <>= call test (mci_vamp_12, "mci_vamp_12", & "unweighted events with grid I/O", & u, results) <>= public :: mci_vamp_12 <>= subroutine mci_vamp_12 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_12" write (u, "(A)") "* Purpose: integrate function in two dimensions & &(two channels)" write (u, "(A)") "* and generate an unweighted event" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) call mci%set_grid_filename (var_str ("mci_vamp_12")) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_2_t :: sampler) write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") call mci%add_pass () call mci%integrate (mci_instance, sampler, 1, 1000) write (u, "(A)") "* Reset instance" write (u, "(A)") call mci_instance%final () call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Generate an unweighted event" write (u, "(A)") call mci_instance%init_simulation () call mci%generate_unweighted_event (mci_instance, sampler) write (u, "(1x,A)") "MCI instance:" call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final_simulation () call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_12" end subroutine mci_vamp_12 @ %def mci_vamp_12 @ \subsubsection{Update integration results} Compare two [[mci]] objects; match the two and update the first if successful. <>= call test (mci_vamp_13, "mci_vamp_13", & "updating integration results", & u, results) <>= public :: mci_vamp_13 <>= subroutine mci_vamp_13 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci, mci_ref logical :: success write (u, "(A)") "* Test output: mci_vamp_13" write (u, "(A)") "* Purpose: match and update integrators" write (u, "(A)") write (u, "(A)") "* Initialize integrator with no passes" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize reference" write (u, "(A)") allocate (mci_vamp_t :: mci_ref) call mci_ref%set_dimensions (2, 2) select type (mci_ref) type is (mci_vamp_t) call mci_ref%set_grid_parameters (grid_par) end select select type (mci_ref) type is (mci_vamp_t) call mci_ref%add_pass (adapt_grids = .true.) call mci_ref%current_pass%configure (2, 1000, 0, 1, 5, 0) mci_ref%current_pass%calls = [77, 77] mci_ref%current_pass%integral = [1.23_default, 3.45_default] mci_ref%current_pass%error = [0.23_default, 0.45_default] mci_ref%current_pass%efficiency = [0.1_default, 0.6_default] mci_ref%current_pass%integral_defined = .true. call mci_ref%add_pass () call mci_ref%current_pass%configure (2, 2000, 0, 1, 7, 0) mci_ref%current_pass%calls = [99, 0] mci_ref%current_pass%integral = [7.89_default, 0._default] mci_ref%current_pass%error = [0.89_default, 0._default] mci_ref%current_pass%efficiency = [0.86_default, 0._default] mci_ref%current_pass%integral_defined = .true. end select call mci_ref%write (u) write (u, "(A)") write (u, "(A)") "* Update integrator (no-op, should succeed)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%update_from_ref (mci_ref, success) end select write (u, "(1x,A,L1)") "success = ", success write (u, "(A)") call mci%write (u) write (u, "(A)") write (u, "(A)") "* Add pass to integrator" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) call mci%current_pass%configure (2, 1000, 0, 1, 5, 0) mci%current_pass%calls = [77, 77] mci%current_pass%integral = [1.23_default, 3.45_default] mci%current_pass%error = [0.23_default, 0.45_default] mci%current_pass%efficiency = [0.1_default, 0.6_default] mci%current_pass%integral_defined = .true. end select write (u, "(A)") "* Update integrator (no-op, should succeed)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%update_from_ref (mci_ref, success) end select write (u, "(1x,A,L1)") "success = ", success write (u, "(A)") call mci%write (u) write (u, "(A)") write (u, "(A)") "* Add pass to integrator, wrong parameters" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass () call mci%current_pass%configure (2, 1000, 0, 1, 7, 0) end select write (u, "(A)") "* Update integrator (should fail)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%update_from_ref (mci_ref, success) end select write (u, "(1x,A,L1)") "success = ", success write (u, "(A)") call mci%write (u) write (u, "(A)") write (u, "(A)") "* Reset and add passes to integrator" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%reset () call mci%add_pass (adapt_grids = .true.) call mci%current_pass%configure (2, 1000, 0, 1, 5, 0) mci%current_pass%calls = [77, 77] mci%current_pass%integral = [1.23_default, 3.45_default] mci%current_pass%error = [0.23_default, 0.45_default] mci%current_pass%efficiency = [0.1_default, 0.6_default] mci%current_pass%integral_defined = .true. call mci%add_pass () call mci%current_pass%configure (2, 2000, 0, 1, 7, 0) end select write (u, "(A)") "* Update integrator (should succeed)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%update_from_ref (mci_ref, success) end select write (u, "(1x,A,L1)") "success = ", success write (u, "(A)") call mci%write (u) write (u, "(A)") write (u, "(A)") "* Update again (no-op, should succeed)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%update_from_ref (mci_ref, success) end select write (u, "(1x,A,L1)") "success = ", success write (u, "(A)") call mci%write (u) write (u, "(A)") write (u, "(A)") "* Add extra result to integrator" write (u, "(A)") select type (mci) type is (mci_vamp_t) mci%current_pass%calls(2) = 1234 end select write (u, "(A)") "* Update integrator (should fail)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%update_from_ref (mci_ref, success) end select write (u, "(1x,A,L1)") "success = ", success write (u, "(A)") call mci%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci%final () call mci_ref%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_13" end subroutine mci_vamp_13 @ %def mci_vamp_13 @ \subsubsection{Accuracy Goal} Integrate with multiple iterations. Skip iterations once an accuracy goal has been reached. <>= call test (mci_vamp_14, "mci_vamp_14", & "accuracy goal", & u, results) <>= public :: mci_vamp_14 <>= subroutine mci_vamp_14 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_14" write (u, "(A)") "* Purpose: integrate function in one dimension & &(single channel)" write (u, "(A)") "* and check accuracy goal" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 1) select type (mci) type is (mci_vamp_t) grid_par%use_vamp_equivalences = .false. grid_par%accuracy_goal = 5E-2_default call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_1_t :: sampler) select type (sampler) type is (test_sampler_1_t) sampler%mode = 2 end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 5 and n_calls = 100" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 5, 100) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_14" end subroutine mci_vamp_14 @ %def mci_vamp_14 @ \subsubsection{VAMP history} Integrate with three passes and different settings for weight and grid adaptation. Then show the VAMP history. <>= call test (mci_vamp_15, "mci_vamp_15", & "VAMP history", & u, results) <>= public :: mci_vamp_15 <>= subroutine mci_vamp_15 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par type(history_parameters_t) :: history_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_15" write (u, "(A)") "* Purpose: integrate function in one dimension & &(two channels)" write (u, "(A)") "* in three passes, show history" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") history_par%channel = .true. allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) call mci%set_history_parameters (history_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_3_t :: sampler) select type (sampler) type is (test_sampler_3_t) sampler%a = 0.9_default sampler%b = 0.1_default end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Pass 1: grid and weight adaptation" select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true., adapt_weights = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) write (u, "(A)") write (u, "(A)") "* Pass 2: grid adaptation" select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) write (u, "(A)") write (u, "(A)") "* Pass 3: without adaptation" select type (mci) type is (mci_vamp_t) call mci%add_pass () end select call mci%integrate (mci_instance, sampler, 3, 1000) write (u, "(A)") write (u, "(A)") "* Contents of MCI record, with history" write (u, "(A)") call mci%write (u) select type (mci) type is (mci_vamp_t) call mci%write_history (u) end select write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_15" end subroutine mci_vamp_15 @ %def mci_vamp_15 @ \subsubsection{One-dimensional integration with sign change} Construct an integrator and use it for a one-dimensional sampler. <>= call test (mci_vamp_16, "mci_vamp_16", & "1-D integral with sign change", & u, results) <>= public :: mci_vamp_16 <>= subroutine mci_vamp_16 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_16" write (u, "(A)") "* Purpose: integrate function in one dimension & &(single channel)" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 1) select type (mci) type is (mci_vamp_t) grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) mci%negative_weights = .true. end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_1_t :: sampler) select type (sampler) type is (test_sampler_1_t) sampler%mode = 4 end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_calls = 1000" write (u, "(A)") " (lower precision to avoid" write (u, "(A)") " numerical noise)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass () end select call mci%integrate (mci_instance, sampler, 1, 1000, pacify = .true.) call mci%write (u, .true.) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u, .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_16" end subroutine mci_vamp_16 @ %def mci_vamp_16 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Multi-channel integration with VAMP2} \label{sec:vegas-integration} The multi-channel integration uses VEGAS as backbone integrator. The base interface for the multi-channel integration is given by [[mci_base]] module. We interface the VAMP2 interface given by [[vamp2]] module. <<[[mci_vamp2.f90]]>>= <> module mci_vamp2 <> <> use phs_base use rng_base use mci_base use vamp2 <> <> <> <> interface <> end interface contains <> end module mci_vamp2 @ %def mci_vamp2 @ <<[[mci_vamp2_sub.f90]]>>= <> submodule (mci_vamp2) mci_vamp2_s use io_units use format_utils, only: pac_fmt use format_utils, only: write_separator, write_indent use format_defs, only: FMT_12, FMT_14, FMT_17, FMT_19 use constants, only: tiny_13 use diagnostics use md5 use os_interface, only: mpi_get_comm_id use rng_stream, only: rng_stream_t use vegas, only: VEGAS_MODE_IMPORTANCE, VEGAS_MODE_IMPORTANCE_ONLY <> implicit none contains <> end submodule mci_vamp2_s @ %def mci_vamp2_s @ \subsection{Type: mci\_vamp2\_func\_t} \label{sec:mci-vamp2-func} <>= type, extends (vamp2_func_t) :: mci_vamp2_func_t private - real(default) :: integrand = 0. + real(default) :: integrand = 0._default class(mci_sampler_t), pointer :: sampler => null () class(mci_vamp2_instance_t), pointer :: instance => null () contains <> end type mci_vamp2_func_t @ %def mci_vamp2_func_t @ Set instance and sampler aka workspace. Also, reset number of [[n_calls]]. <>= procedure, public :: set_workspace => mci_vamp2_func_set_workspace <>= module subroutine mci_vamp2_func_set_workspace (self, instance, sampler) class(mci_vamp2_func_t), intent(inout) :: self class(mci_vamp2_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler end subroutine mci_vamp2_func_set_workspace <>= module subroutine mci_vamp2_func_set_workspace (self, instance, sampler) class(mci_vamp2_func_t), intent(inout) :: self class(mci_vamp2_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler self%instance => instance self%sampler => sampler end subroutine mci_vamp2_func_set_workspace @ %def mci_vamp2_func_set_workspace @ Get the different channel probabilities. <>= procedure, public :: get_probabilities => mci_vamp2_func_get_probabilities <>= module function mci_vamp2_func_get_probabilities (self) result (gi) class(mci_vamp2_func_t), intent(inout) :: self real(default), dimension(self%n_channel) :: gi end function mci_vamp2_func_get_probabilities <>= module function mci_vamp2_func_get_probabilities (self) result (gi) class(mci_vamp2_func_t), intent(inout) :: self real(default), dimension(self%n_channel) :: gi gi = self%gi end function mci_vamp2_func_get_probabilities @ %def mci_vamp2_func_get_probabilities @ Get multi-channel weight. <>= procedure, public :: get_weight => mci_vamp2_func_get_weight <>= module function mci_vamp2_func_get_weight (self) result (g) class(mci_vamp2_func_t), intent(in) :: self real(default) :: g end function mci_vamp2_func_get_weight <>= module function mci_vamp2_func_get_weight (self) result (g) class(mci_vamp2_func_t), intent(in) :: self real(default) :: g g = self%g end function mci_vamp2_func_get_weight @ %def mci_vamp2_func_get_weight @ Set integrand. <>= procedure, public :: set_integrand => mci_vamp2_func_set_integrand <>= module subroutine mci_vamp2_func_set_integrand (self, integrand) class(mci_vamp2_func_t), intent(inout) :: self real(default), intent(in) :: integrand end subroutine mci_vamp2_func_set_integrand <>= module subroutine mci_vamp2_func_set_integrand (self, integrand) class(mci_vamp2_func_t), intent(inout) :: self real(default), intent(in) :: integrand self%integrand = integrand end subroutine mci_vamp2_func_set_integrand @ %def mci_vamp2_func_set_integrand @ Evaluate the mappings. <>= procedure, public :: evaluate_maps => mci_vamp2_func_evaluate_maps <>= module subroutine mci_vamp2_func_evaluate_maps (self, x) class(mci_vamp2_func_t), intent(inout) :: self real(default), dimension(:), intent(in) :: x end subroutine mci_vamp2_func_evaluate_maps <>= module subroutine mci_vamp2_func_evaluate_maps (self, x) class(mci_vamp2_func_t), intent(inout) :: self real(default), dimension(:), intent(in) :: x select type (self) type is (mci_vamp2_func_t) call self%instance%evaluate (self%sampler, self%current_channel, x) end select self%valid_x = self%instance%valid self%xi = self%instance%x self%det = self%instance%f end subroutine mci_vamp2_func_evaluate_maps @ %def mci_vamp2_func_evaluate_maps @ Evaluate the function, more or less. <>= procedure, public :: evaluate_func => mci_vamp2_func_evaluate_func <>= module function mci_vamp2_func_evaluate_func (self, x) result (f) class(mci_vamp2_func_t), intent(in) :: self real(default), dimension(:), intent(in) :: x real(default) :: f end function mci_vamp2_func_evaluate_func <>= module function mci_vamp2_func_evaluate_func (self, x) result (f) class(mci_vamp2_func_t), intent(in) :: self real(default), dimension(:), intent(in) :: x real(default) :: f f = self%integrand if (signal_is_pending ()) then call msg_message ("VAMP2: function evaluate_func: signal received") call terminate_now_if_signal () end if call terminate_now_if_single_event () end function mci_vamp2_func_evaluate_func @ %def mci_vamp2_func_evaluate_func @ \subsection{Type: mci\_vamp2\_config\_t} We extend [[vamp2_config_t]]. <>= public :: mci_vamp2_config_t <>= type, extends (vamp2_config_t) :: mci_vamp2_config_t ! end type mci_vamp2_config_t @ %def mci_vamp2_config_t @ \subsection{Integration pass} The list of passes is organized in a separate container. We store the parameters and results for each integration pass in [[pass_t]] and the linked list is stored in [[list_pass_t]]. <>= type :: list_pass_t type(pass_t), pointer :: first => null () type(pass_t), pointer :: current => null () contains <> end type list_pass_t @ %def list_pass_t @ Finalizer. Deallocate each element of the list beginning by the first. <>= procedure :: final => list_pass_final <>= module subroutine list_pass_final (self) class(list_pass_t), intent(inout) :: self end subroutine list_pass_final <>= module subroutine list_pass_final (self) class(list_pass_t), intent(inout) :: self type(pass_t), pointer :: current current => self%first do while (associated (current)) self%first => current%next deallocate (current) current => self%first end do end subroutine list_pass_final @ %def pass_final @ Add a new pass. <>= procedure :: add => list_pass_add <>= module subroutine list_pass_add & (self, adapt_grids, adapt_weights, final_pass) class(list_pass_t), intent(inout) :: self logical, intent(in), optional :: adapt_grids, adapt_weights, final_pass end subroutine list_pass_add <>= module subroutine list_pass_add & (self, adapt_grids, adapt_weights, final_pass) class(list_pass_t), intent(inout) :: self logical, intent(in), optional :: adapt_grids, adapt_weights, final_pass type(pass_t), pointer :: new_pass allocate (new_pass) new_pass%i_pass = 1 new_pass%i_first_it = 1 new_pass%adapt_grids = .false.; if (present (adapt_grids)) & & new_pass%adapt_grids = adapt_grids new_pass%adapt_weights = .false.; if (present (adapt_weights)) & & new_pass%adapt_weights = adapt_weights new_pass%is_final_pass = .false.; if (present (final_pass)) & & new_pass%is_final_pass = final_pass if (.not. associated (self%first)) then self%first => new_pass else new_pass%i_pass = new_pass%i_pass + self%current%i_pass new_pass%i_first_it = self%current%i_first_it + self%current%n_it self%current%next => new_pass end if self%current => new_pass end subroutine list_pass_add @ %def list_pass_add @ Update list from a reference. All passes except for the last one must match exactly. For the last one, integration results are updated. The reference output may contain extra passes, these are ignored. <>= procedure :: update_from_ref => list_pass_update_from_ref <>= module subroutine list_pass_update_from_ref (self, ref, success) class(list_pass_t), intent(inout) :: self type(list_pass_t), intent(in) :: ref logical, intent(out) :: success end subroutine list_pass_update_from_ref <>= module subroutine list_pass_update_from_ref (self, ref, success) class(list_pass_t), intent(inout) :: self type(list_pass_t), intent(in) :: ref logical, intent(out) :: success type(pass_t), pointer :: current, ref_current current => self%first ref_current => ref%first success = .true. do while (success .and. associated (current)) if (associated (ref_current)) then if (associated (current%next)) then success = current .matches. ref_current else call current%update (ref_current, success) end if current => current%next ref_current => ref_current%next else success = .false. end if end do end subroutine list_pass_update_from_ref @ %def list_pass_update_from_ref <>= procedure :: has_last_integral => list_pass_has_last_integral procedure :: get_last_integral => list_pass_get_last_integral <>= module function list_pass_has_last_integral(self) result (flag) class(list_pass_t), intent(in) :: self logical :: flag end function list_pass_has_last_integral module subroutine list_pass_get_last_integral & (self, integral, error, efficiency) class(list_pass_t), intent(in) :: self real(default), intent(out) :: integral real(default), intent(out) :: error real(default), intent(out) :: efficiency end subroutine list_pass_get_last_integral <>= module function list_pass_has_last_integral(self) result (flag) class(list_pass_t), intent(in) :: self logical :: flag flag = associated(self%current) if (flag) flag = self%current%integral_defined end function list_pass_has_last_integral module subroutine list_pass_get_last_integral & (self, integral, error, efficiency) class(list_pass_t), intent(in) :: self real(default), intent(out) :: integral real(default), intent(out) :: error real(default), intent(out) :: efficiency if (self%has_last_integral()) then integral = self%current%get_integral() error = self%current%get_error() efficiency = self%current%get_efficiency() else integral = 0 error = 0 efficiency = 0 end if end subroutine list_pass_get_last_integral @ %def list_pass_has_last_integral list_pass_get_last_integral @ Output. Write the complete linked list to the specified unit. <>= procedure :: write => list_pass_write <>= module subroutine list_pass_write (self, unit, pacify) class(list_pass_t), intent(in) :: self integer, intent(in) :: unit logical, intent(in), optional :: pacify end subroutine list_pass_write <>= module subroutine list_pass_write (self, unit, pacify) class(list_pass_t), intent(in) :: self integer, intent(in) :: unit logical, intent(in), optional :: pacify type(pass_t), pointer :: current current => self%first do while (associated (current)) write (unit, "(1X,A)") "Integration pass:" call current%write (unit, pacify) current => current%next end do end subroutine list_pass_write @ %def list_pass_write @ The parameters and results are stored in the nodes [[pass_t]] of the linked list. <>= type :: pass_t integer :: i_pass = 0 integer :: i_first_it = 0 integer :: n_it = 0 integer :: n_calls = 0 logical :: adapt_grids = .false. logical :: adapt_weights = .false. logical :: is_final_pass = .false. logical :: integral_defined = .false. integer, dimension(:), allocatable :: calls integer, dimension(:), allocatable :: calls_valid real(default), dimension(:), allocatable :: integral real(default), dimension(:), allocatable :: error real(default), dimension(:), allocatable :: efficiency type(pass_t), pointer :: next => null () contains <> end type pass_t @ %def pass_t @ Output. Note that the precision of the numerical values should match the precision for comparing output from file with data. <>= procedure :: write => pass_write <>= module subroutine pass_write (self, unit, pacify) class(pass_t), intent(in) :: self integer, intent(in) :: unit logical, intent(in), optional :: pacify end subroutine pass_write <>= module subroutine pass_write (self, unit, pacify) class(pass_t), intent(in) :: self integer, intent(in) :: unit logical, intent(in), optional :: pacify integer :: u, i real(default) :: pac_error character(len=7) :: fmt call pac_fmt (fmt, FMT_17, FMT_14, pacify) u = given_output_unit (unit) write (u, "(3X,A,I0)") "n_it = ", self%n_it write (u, "(3X,A,I0)") "n_calls = ", self%n_calls write (u, "(3X,A,L1)") "adapt grids = ", self%adapt_grids write (u, "(3X,A,L1)") "adapt weights = ", self%adapt_weights if (self%integral_defined) then write (u, "(3X,A)") "Results: [it, calls, valid, integral, error, efficiency]" do i = 1, self%n_it if (abs (self%error(i)) > tiny_13) then pac_error = self%error(i) else pac_error = 0 end if write (u, "(5x,I0,2(1x,I0),3(1x," // fmt // "))") & i, self%calls(i), self%calls_valid(i), self%integral(i), & pac_error, self%efficiency(i) end do else write (u, "(3x,A)") "Results: [undefined]" end if end subroutine pass_write @ %def pass_write @ Read and reconstruct the pass. <>= procedure :: read => pass_read <>= module subroutine pass_read (self, u, n_pass, n_it) class(pass_t), intent(out) :: self integer, intent(in) :: u, n_pass, n_it end subroutine pass_read <>= module subroutine pass_read (self, u, n_pass, n_it) class(pass_t), intent(out) :: self integer, intent(in) :: u, n_pass, n_it integer :: i, j character(80) :: buffer self%i_pass = n_pass + 1 self%i_first_it = n_it + 1 call read_ival (u, self%n_it) call read_ival (u, self%n_calls) call read_lval (u, self%adapt_grids) call read_lval (u, self%adapt_weights) allocate (self%calls (self%n_it), source = 0) allocate (self%calls_valid (self%n_it), source = 0) allocate (self%integral (self%n_it), source = 0._default) allocate (self%error (self%n_it), source = 0._default) allocate (self%efficiency (self%n_it), source = 0._default) read (u, "(A)") buffer select case (trim (adjustl (buffer))) case ("Results: [it, calls, valid, integral, error, efficiency]") do i = 1, self%n_it read (u, *) & j, self%calls(i), self%calls_valid(i), self%integral(i), self%error(i), & self%efficiency(i) end do self%integral_defined = .true. case ("Results: [undefined]") self%integral_defined = .false. case default call msg_fatal ("Reading integration pass: corrupted file") end select end subroutine pass_read @ %def pass_read @ Auxiliary: Read real, integer, string value. We search for an equals sign, the value must follow. <>= subroutine read_rval (u, rval) integer, intent(in) :: u real(default), intent(out) :: rval character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) rval end subroutine read_rval subroutine read_ival (u, ival) integer, intent(in) :: u integer, intent(out) :: ival character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) ival end subroutine read_ival subroutine read_sval (u, sval) integer, intent(in) :: u character(*), intent(out) :: sval character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) sval end subroutine read_sval subroutine read_lval (u, lval) integer, intent(in) :: u logical, intent(out) :: lval character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) lval end subroutine read_lval @ %def read_rval read_ival read_sval read_lval @ Configure. We adjust the number of [[n_calls]], if it is lower than [[n_calls_min_per_channel]] times [[b_channel]], and print a warning message. <>= procedure :: configure => pass_configure <>= module subroutine pass_configure (pass, n_it, n_calls, n_calls_min) class(pass_t), intent(inout) :: pass integer, intent(in) :: n_it integer, intent(in) :: n_calls integer, intent(in) :: n_calls_min end subroutine pass_configure <>= module subroutine pass_configure (pass, n_it, n_calls, n_calls_min) class(pass_t), intent(inout) :: pass integer, intent(in) :: n_it integer, intent(in) :: n_calls integer, intent(in) :: n_calls_min pass%n_it = n_it pass%n_calls = max (n_calls, n_calls_min) if (pass%n_calls /= n_calls) then write (msg_buffer, "(A,I0)") "VAMP2: too few calls, resetting " & // "n_calls to ", pass%n_calls call msg_warning () end if allocate (pass%calls (n_it), source = 0) allocate (pass%calls_valid (n_it), source = 0) allocate (pass%integral (n_it), source = 0._default) allocate (pass%error (n_it), source = 0._default) allocate (pass%efficiency (n_it), source = 0._default) end subroutine pass_configure @ %def pass_configure @ Given two pass objects, compare them. All parameters must match. Where integrations are done in both (number of calls nonzero), the results must be equal (up to numerical noise). The allocated array sizes might be different, but should match up to the common [[n_it]] value. <>= interface operator (.matches.) module procedure pass_matches end interface operator (.matches.) <>= module function pass_matches (pass, ref) result (ok) type(pass_t), intent(in) :: pass, ref logical :: ok end function pass_matches <>= module function pass_matches (pass, ref) result (ok) type(pass_t), intent(in) :: pass, ref integer :: n logical :: ok ok = .true. if (ok) ok = pass%i_pass == ref%i_pass if (ok) ok = pass%i_first_it == ref%i_first_it if (ok) ok = pass%n_it == ref%n_it if (ok) ok = pass%n_calls == ref%n_calls if (ok) ok = pass%adapt_grids .eqv. ref%adapt_grids if (ok) ok = pass%adapt_weights .eqv. ref%adapt_weights if (ok) ok = pass%integral_defined .eqv. ref%integral_defined if (pass%integral_defined) then n = pass%n_it if (ok) ok = all (pass%calls(:n) == ref%calls(:n)) if (ok) ok = all (pass%calls_valid(:n) == ref%calls_valid(:n)) if (ok) ok = all (pass%integral(:n) .matches. ref%integral(:n)) if (ok) ok = all (pass%error(:n) .matches. ref%error(:n)) if (ok) ok = all (pass%efficiency(:n) .matches. ref%efficiency(:n)) end if end function pass_matches @ %def pass_matches @ Update a pass object, given a reference. The parameters must match, except for the [[n_it]] entry. The number of complete iterations must be less or equal to the reference, and the number of complete iterations in the reference must be no larger than [[n_it]]. Where results are present in both passes, they must match. Where results are present in the reference only, the pass is updated accordingly. <>= procedure :: update => pass_update <>= module subroutine pass_update (pass, ref, ok) class(pass_t), intent(inout) :: pass type(pass_t), intent(in) :: ref logical, intent(out) :: ok end subroutine pass_update <>= module subroutine pass_update (pass, ref, ok) class(pass_t), intent(inout) :: pass type(pass_t), intent(in) :: ref logical, intent(out) :: ok integer :: n, n_ref ok = .true. if (ok) ok = pass%i_pass == ref%i_pass if (ok) ok = pass%i_first_it == ref%i_first_it if (ok) ok = pass%n_calls == ref%n_calls if (ok) ok = pass%adapt_grids .eqv. ref%adapt_grids if (ok) ok = pass%adapt_weights .eqv. ref%adapt_weights if (ok) then if (ref%integral_defined) then if (.not. allocated (pass%calls)) then allocate (pass%calls (pass%n_it), source = 0) allocate (pass%calls_valid (pass%n_it), source = 0) allocate (pass%integral (pass%n_it), source = 0._default) allocate (pass%error (pass%n_it), source = 0._default) allocate (pass%efficiency (pass%n_it), source = 0._default) end if n = count (pass%calls /= 0) n_ref = count (ref%calls /= 0) ok = n <= n_ref .and. n_ref <= pass%n_it if (ok) ok = all (pass%calls(:n) == ref%calls(:n)) if (ok) ok = all (pass%calls_valid(:n) == ref%calls_valid(:n)) if (ok) ok = all (pass%integral(:n) .matches. ref%integral(:n)) if (ok) ok = all (pass%error(:n) .matches. ref%error(:n)) if (ok) ok = all (pass%efficiency(:n) .matches. ref%efficiency(:n)) if (ok) then pass%calls(n+1:n_ref) = ref%calls(n+1:n_ref) pass%calls_valid(n+1:n_ref) = ref%calls_valid(n+1:n_ref) pass%integral(n+1:n_ref) = ref%integral(n+1:n_ref) pass%error(n+1:n_ref) = ref%error(n+1:n_ref) pass%efficiency(n+1:n_ref) = ref%efficiency(n+1:n_ref) pass%integral_defined = any (pass%calls /= 0) end if end if end if end subroutine pass_update @ %def pass_update @ Match two real numbers: they are equal up to a tolerance, which is $10^{-8}$, matching the number of digits that are output by [[pass_write]]. In particular, if one number is exactly zero, the other one must also be zero. <>= interface operator (.matches.) module procedure real_matches end interface operator (.matches.) <>= elemental module function real_matches (x, y) result (ok) real(default), intent(in) :: x, y logical :: ok end function real_matches <>= elemental module function real_matches (x, y) result (ok) real(default), intent(in) :: x, y logical :: ok real(default), parameter :: tolerance = 1.e-8_default ok = abs (x - y) <= tolerance * max (abs (x), abs (y)) end function real_matches @ %def real_matches @ Return the index of the most recent complete integration. If there is none, return zero. <>= procedure :: get_integration_index => pass_get_integration_index <>= module function pass_get_integration_index (pass) result (n) class (pass_t), intent(in) :: pass integer :: n end function pass_get_integration_index <>= module function pass_get_integration_index (pass) result (n) class (pass_t), intent(in) :: pass integer :: n integer :: i n = 0 if (allocated (pass%calls)) then do i = 1, pass%n_it if (pass%calls(i) == 0) exit n = i end do end if end function pass_get_integration_index @ %def pass_get_integration_index @ Return the most recent integral and error, if available. <>= procedure :: get_calls => pass_get_calls procedure :: get_calls_valid => pass_get_calls_valid procedure :: get_integral => pass_get_integral procedure :: get_error => pass_get_error procedure :: get_efficiency => pass_get_efficiency <>= module function pass_get_calls (pass) result (calls) class(pass_t), intent(in) :: pass integer :: calls end function pass_get_calls module function pass_get_calls_valid (pass) result (valid) class(pass_t), intent(in) :: pass integer :: valid end function pass_get_calls_valid module function pass_get_integral (pass) result (integral) class(pass_t), intent(in) :: pass real(default) :: integral end function pass_get_integral module function pass_get_error (pass) result (error) class(pass_t), intent(in) :: pass real(default) :: error end function pass_get_error module function pass_get_efficiency (pass) result (efficiency) class(pass_t), intent(in) :: pass real(default) :: efficiency end function pass_get_efficiency <>= module function pass_get_calls (pass) result (calls) class(pass_t), intent(in) :: pass integer :: calls integer :: n n = pass%get_integration_index () calls = 0 if (n /= 0) then calls = pass%calls(n) end if end function pass_get_calls module function pass_get_calls_valid (pass) result (valid) class(pass_t), intent(in) :: pass integer :: valid integer :: n n = pass%get_integration_index () valid = 0 if (n /= 0) then valid = pass%calls_valid(n) end if end function pass_get_calls_valid module function pass_get_integral (pass) result (integral) class(pass_t), intent(in) :: pass real(default) :: integral integer :: n n = pass%get_integration_index () integral = 0 if (n /= 0) then integral = pass%integral(n) end if end function pass_get_integral module function pass_get_error (pass) result (error) class(pass_t), intent(in) :: pass real(default) :: error integer :: n n = pass%get_integration_index () error = 0 if (n /= 0) then error = pass%error(n) end if end function pass_get_error module function pass_get_efficiency (pass) result (efficiency) class(pass_t), intent(in) :: pass real(default) :: efficiency integer :: n n = pass%get_integration_index () efficiency = 0 if (n /= 0) then efficiency = pass%efficiency(n) end if end function pass_get_efficiency @ %def pass_get_calls @ %def pass_get_calls_valid @ %def pass_get_integral @ %def pass_get_error @ %def pass_get_efficiency @ \subsection{Integrator} \label{sec:integrator} We store the different passes of integration, adaptation and actual sampling, in a linked list. We store the total number of calls [[n_calls]] and the minimal number of calls [[n_calls_min]]. The latter is calculated based on [[n_channel]] and [[min_calls_per_channel]]. If [[n_calls]] is smaller than [[n_calls_min]], then we replace [[n_calls]] with [[n_min_calls]]. <>= public :: mci_vamp2_t <>= type, extends(mci_t) :: mci_vamp2_t type(mci_vamp2_config_t) :: config type(vamp2_t) :: integrator type(vamp2_equivalences_t) :: equivalences logical :: integrator_defined = .false. logical :: integrator_from_file = .false. logical :: adapt_grids = .false. logical :: adapt_weights = .false. integer :: n_adapt_grids = 0 integer :: n_adapt_weights = 0 integer :: n_calls = 0 type(list_pass_t) :: list_pass logical :: rebuild = .true. logical :: check_grid_file = .true. logical :: grid_filename_set = .false. logical :: negative_weights = .false. logical :: verbose = .false. logical :: pass_complete = .false. logical :: it_complete = .false. type(string_t) :: grid_filename integer :: grid_checkpoint = 1 logical :: binary_grid_format = .false. type(string_t) :: parallel_method character(32) :: md5sum_adapted = "" contains <> end type mci_vamp2_t @ %def mci_vamp2_t @ Finalizer: call to base and list finalizer. <>= procedure, public :: final => mci_vamp2_final <>= module subroutine mci_vamp2_final (object) class(mci_vamp2_t), intent(inout) :: object end subroutine mci_vamp2_final <>= module subroutine mci_vamp2_final (object) class(mci_vamp2_t), intent(inout) :: object call object%list_pass%final () call object%base_final () end subroutine mci_vamp2_final @ %def mci_vamp2_final @ Output. Do not output the grids themselves, this may result in tons of data. <>= procedure, public :: write => mci_vamp2_write <>= module subroutine mci_vamp2_write (object, unit, pacify, md5sum_version) class(mci_vamp2_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version end subroutine mci_vamp2_write <>= module subroutine mci_vamp2_write (object, unit, pacify, md5sum_version) class(mci_vamp2_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version integer :: u, i u = given_output_unit (unit) write (u, "(1X,A)") "VAMP2 integrator:" call object%base_write (u, pacify, md5sum_version) write (u, "(1X,A)") "Grid config:" call object%config%write (u) write (u, "(3X,A,L1)") "Integrator defined = ", object%integrator_defined write (u, "(3X,A,L1)") "Integrator from file = ", object%integrator_from_file write (u, "(3X,A,L1)") "Adapt grids = ", object%adapt_grids write (u, "(3X,A,L1)") "Adapt weights = ", object%adapt_weights write (u, "(3X,A,I0)") "No. of adapt grids = ", object%n_adapt_grids write (u, "(3X,A,I0)") "No. of adapt weights = ", object%n_adapt_weights write (u, "(3X,A,L1)") "Verbose = ", object%verbose if (object%config%equivalences) then call object%equivalences%write (u) end if call object%list_pass%write (u, pacify) if (object%md5sum_adapted /= "") then write (u, "(1X,A,A,A)") "MD5 sum (including results) = '", & & object%md5sum_adapted, "'" end if end subroutine mci_vamp2_write @ %def mci_vamp2_write @ Compute the (adapted) MD5 sum, including the configuration MD5 sum and the printout, which incorporates the current results. <>= procedure, public :: compute_md5sum => mci_vamp2_compute_md5sum <>= module subroutine mci_vamp2_compute_md5sum (mci, pacify) class(mci_vamp2_t), intent(inout) :: mci logical, intent(in), optional :: pacify end subroutine mci_vamp2_compute_md5sum <>= module subroutine mci_vamp2_compute_md5sum (mci, pacify) class(mci_vamp2_t), intent(inout) :: mci logical, intent(in), optional :: pacify integer :: u mci%md5sum_adapted = "" u = free_unit () open (u, status = "scratch", action = "readwrite") write (u, "(A)") mci%md5sum call mci%write (u, pacify, md5sum_version = .true.) rewind (u) mci%md5sum_adapted = md5sum (u) close (u) end subroutine mci_vamp2_compute_md5sum @ %def mci_vamp2_compute_md5sum @ Return the MD5 sum: If available, return the adapted one. <>= procedure, public :: get_md5sum => mci_vamp2_get_md5sum <>= pure module function mci_vamp2_get_md5sum (mci) result (md5sum) class(mci_vamp2_t), intent(in) :: mci character(32) :: md5sum end function mci_vamp2_get_md5sum <>= pure module function mci_vamp2_get_md5sum (mci) result (md5sum) class(mci_vamp2_t), intent(in) :: mci character(32) :: md5sum if (mci%md5sum_adapted /= "") then md5sum = mci%md5sum_adapted else md5sum = mci%md5sum end if end function mci_vamp2_get_md5sum @ %def mci_vamp_get_md5sum @ Startup message: short version. Make a call to the base function and print additional information about the multi-channel parameters. <>= procedure, public :: startup_message => mci_vamp2_startup_message <>= module subroutine mci_vamp2_startup_message (mci, unit, n_calls) class(mci_vamp2_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls end subroutine mci_vamp2_startup_message <>= module subroutine mci_vamp2_startup_message (mci, unit, n_calls) class(mci_vamp2_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls integer :: num_calls, n_bins num_calls = 0; if (present (n_calls)) num_calls = n_calls n_bins = mci%config%n_bins_max call mci%base_startup_message (unit = unit, n_calls = n_calls) if (mci%config%equivalences) then write (msg_buffer, "(A)") & "Integrator: Using VAMP2 channel equivalences" call msg_message (unit = unit) end if if (mci%binary_grid_format) then write (msg_buffer, "(A,A,A,A)") & "Integrator: Write grid header to '" // char (mci%get_grid_filename ()) // & "' and grids to '" // char (mci%get_grid_filename (binary_grid_format = .true.)) // "'" else write (msg_buffer, "(A,A,A)") & "Integrator: Write grid header and grids to '" // char (mci%get_grid_filename ()) // "'" end if call msg_message (unit = unit) select case (mci%grid_checkpoint) case (0) write (msg_buffer, "(A)") & "Integrator: Grid checkpoint after each pass" case (1) write (msg_buffer, "(A)") & "Integrator: Grid checkpoint after each iteration" case (2:) write (msg_buffer, "(A,1X,I0,1X,A)") & "Integrator: Grid checkpoint after", mci%grid_checkpoint, & "iterations and after each pass" case default call msg_bug ("Integrator: Cannot assign grid checkpoint (value is negative).") end select call msg_message (unit = unit) write (msg_buffer, "(A,2(1x,I0,1x,A),L1)") & "Integrator:", num_calls, & "initial calls,", n_bins, & "max. bins, stratified = ", & mci%config%stratified call msg_message (unit = unit) write (msg_buffer, "(A,2(1x,I0,1x,A))") & "Integrator: VAMP2" call msg_message (unit = unit) end subroutine mci_vamp2_startup_message @ %def mci_vamp2_startup_message @ Log entry: just headline. <>= procedure, public :: write_log_entry => mci_vamp2_write_log_entry <>= module subroutine mci_vamp2_write_log_entry (mci, u) class(mci_vamp2_t), intent(in) :: mci integer, intent(in) :: u end subroutine mci_vamp2_write_log_entry <>= module subroutine mci_vamp2_write_log_entry (mci, u) class(mci_vamp2_t), intent(in) :: mci integer, intent(in) :: u write (u, "(1x,A)") "MC Integrator is VAMP2" call write_separator (u) if (mci%config%equivalences) then call mci%equivalences%write (u) else write (u, "(3x,A)") "No channel equivalences have been used." end if call write_separator (u) call mci%write_chain_weights (u) end subroutine mci_vamp2_write_log_entry @ %def mci_vamp2_write_log_entry @ Set the MCI index (necessary for processes with multiple components). We append the index to the grid filename, just before the final dotted suffix. <>= procedure, public :: record_index => mci_vamp2_record_index <>= module subroutine mci_vamp2_record_index (mci, i_mci) class(mci_vamp2_t), intent(inout) :: mci integer, intent(in) :: i_mci end subroutine mci_vamp2_record_index <>= module subroutine mci_vamp2_record_index (mci, i_mci) class(mci_vamp2_t), intent(inout) :: mci integer, intent(in) :: i_mci type(string_t) :: basename, suffix character(32) :: buffer if (mci%grid_filename_set) then write (buffer, "(I0)") i_mci mci%grid_filename = mci%grid_filename // ".m" // trim (buffer) end if end subroutine mci_vamp2_record_index @ %def mci_vamp2_record_index @ Set the configuration object. We adjust the maximum number of bins [[n_bins_max]] according to [[n_calls]] <>= procedure, public :: set_config => mci_vamp2_set_config <>= module subroutine mci_vamp2_set_config (mci, config) class(mci_vamp2_t), intent(inout) :: mci type(mci_vamp2_config_t), intent(in) :: config end subroutine mci_vamp2_set_config <>= module subroutine mci_vamp2_set_config (mci, config) class(mci_vamp2_t), intent(inout) :: mci type(mci_vamp2_config_t), intent(in) :: config mci%config = config end subroutine mci_vamp2_set_config @ %def mci_vamp2_set_config @ Set the the rebuild flag, also the for checking the grid. <>= procedure, public :: set_rebuild_flag => mci_vamp2_set_rebuild_flag <>= module subroutine mci_vamp2_set_rebuild_flag (mci, rebuild, check_grid_file) class(mci_vamp2_t), intent(inout) :: mci logical, intent(in) :: rebuild logical, intent(in) :: check_grid_file end subroutine mci_vamp2_set_rebuild_flag <>= module subroutine mci_vamp2_set_rebuild_flag (mci, rebuild, check_grid_file) class(mci_vamp2_t), intent(inout) :: mci logical, intent(in) :: rebuild logical, intent(in) :: check_grid_file mci%rebuild = rebuild mci%check_grid_file = check_grid_file end subroutine mci_vamp2_set_rebuild_flag @ %def mci_vegaa_set_rebuild_flag @ Set the filename. <>= procedure, public :: set_grid_filename => mci_vamp2_set_grid_filename procedure, public :: get_grid_filename => mci_vamp2_get_grid_filename <>= module subroutine mci_vamp2_set_grid_filename (mci, name, run_id) class(mci_vamp2_t), intent(inout) :: mci type(string_t), intent(in) :: name type(string_t), intent(in), optional :: run_id end subroutine mci_vamp2_set_grid_filename module function mci_vamp2_get_grid_filename (mci, binary_grid_format) & result (filename) class(mci_vamp2_t), intent(in) :: mci logical, intent(in), optional :: binary_grid_format type(string_t) :: filename end function mci_vamp2_get_grid_filename <>= module subroutine mci_vamp2_set_grid_filename (mci, name, run_id) class(mci_vamp2_t), intent(inout) :: mci type(string_t), intent(in) :: name type(string_t), intent(in), optional :: run_id mci%grid_filename = name if (present (run_id)) then mci%grid_filename = name // "." // run_id end if mci%grid_filename_set = .true. end subroutine mci_vamp2_set_grid_filename module function mci_vamp2_get_grid_filename (mci, binary_grid_format) & result (filename) class(mci_vamp2_t), intent(in) :: mci logical, intent(in), optional :: binary_grid_format type(string_t) :: filename filename = mci%grid_filename // ".vg2" if (present (binary_grid_format)) then if (binary_grid_format) then filename = mci%grid_filename // ".vgx2" end if end if end function mci_vamp2_get_grid_filename @ %def mci_vamp2_set_grid_filename, mci_vamp2_get_grid_filename @ To simplify the interface, we prepend a grid path in a separate subroutine. <>= procedure :: prepend_grid_path => mci_vamp2_prepend_grid_path <>= module subroutine mci_vamp2_prepend_grid_path (mci, prefix) class(mci_vamp2_t), intent(inout) :: mci type(string_t), intent(in) :: prefix end subroutine mci_vamp2_prepend_grid_path <>= module subroutine mci_vamp2_prepend_grid_path (mci, prefix) class(mci_vamp2_t), intent(inout) :: mci type(string_t), intent(in) :: prefix if (.not. mci%grid_filename_set) then call msg_warning & ("VAMP2: Cannot add prefix to invalid integrator filename!") end if mci%grid_filename = prefix // "/" // mci%grid_filename end subroutine mci_vamp2_prepend_grid_path @ %def mci_vamp2_prepend_grid_path @ Not implemented. <>= procedure, public :: declare_flat_dimensions => & mci_vamp2_declare_flat_dimensions <>= module subroutine mci_vamp2_declare_flat_dimensions (mci, dim_flat) class(mci_vamp2_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat end subroutine mci_vamp2_declare_flat_dimensions <>= module subroutine mci_vamp2_declare_flat_dimensions (mci, dim_flat) class(mci_vamp2_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat end subroutine mci_vamp2_declare_flat_dimensions @ %def mci_vamp2_declare_flat_dimensions @ <>= procedure, public :: declare_equivalences => mci_vamp2_declare_equivalences <>= module subroutine mci_vamp2_declare_equivalences (mci, channel, dim_offset) class(mci_vamp2_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset end subroutine mci_vamp2_declare_equivalences <>= module subroutine mci_vamp2_declare_equivalences (mci, channel, dim_offset) class(mci_vamp2_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset integer, dimension(:), allocatable :: perm, mode integer :: n_channels, n_dim, n_equivalences integer :: c, i, j, dest, src integer :: n_dim_perm n_channels = mci%n_channel n_dim = mci%n_dim n_equivalences = 0 do c = 1, n_channels n_equivalences = n_equivalences + size (channel(c)%eq) end do mci%equivalences = vamp2_equivalences_t (& n_eqv = n_equivalences, n_channel = n_channels, n_dim = n_dim) allocate (perm (n_dim)) allocate (mode (n_dim)) perm = [(i, i = 1, n_dim)] mode = 0 c = 1 j = 0 do i = 1, n_equivalences if (j < size (channel(c)%eq)) then j = j + 1 else c = c + 1 j = 1 end if associate (eq => channel(c)%eq(j)) dest = c src = eq%c n_dim_perm = size (eq%perm) perm(dim_offset+1:dim_offset+n_dim_perm) = eq%perm + dim_offset mode(dim_offset+1:dim_offset+n_dim_perm) = eq%mode call mci%equivalences%set_equivalence & (i, dest, src, perm, mode) end associate end do call mci%equivalences%freeze () end subroutine mci_vamp2_declare_equivalences @ %def mci_vamp2_declare_quivalences @ Allocate instance with matching type. Gfortran 7/8/9 bug, has to remain in the main module: <>= procedure, public :: allocate_instance => mci_vamp2_allocate_instance <>= subroutine mci_vamp2_allocate_instance (mci, mci_instance) class(mci_vamp2_t), intent(in) :: mci class(mci_instance_t), intent(out), pointer :: mci_instance allocate (mci_vamp2_instance_t :: mci_instance) end subroutine mci_vamp2_allocate_instance @ %def mci_vamp2_allocate_instance @ Allocate a new integration pass. We can preset everything that does not depend on the number of iterations and calls. This is postponed to the integrate method. In the final pass, we do not check accuracy goal etc., since we can assume that the user wants to perform and average all iterations in this pass. <>= procedure, public :: add_pass => mci_vamp2_add_pass <>= module subroutine mci_vamp2_add_pass & (mci, adapt_grids, adapt_weights, final_pass) class(mci_vamp2_t), intent(inout) :: mci logical, intent(in), optional :: adapt_grids, adapt_weights, final_pass end subroutine mci_vamp2_add_pass <>= module subroutine mci_vamp2_add_pass & (mci, adapt_grids, adapt_weights, final_pass) class(mci_vamp2_t), intent(inout) :: mci logical, intent(in), optional :: adapt_grids, adapt_weights, final_pass call mci%list_pass%add (adapt_grids, adapt_weights, final_pass) end subroutine mci_vamp2_add_pass @ %def mci_vamp2_add_pass @ Update the list of integration passes. <>= procedure, public :: update_from_ref => mci_vamp2_update_from_ref <>= module subroutine mci_vamp2_update_from_ref (mci, mci_ref, success) class(mci_vamp2_t), intent(inout) :: mci class(mci_t), intent(in) :: mci_ref logical, intent(out) :: success end subroutine mci_vamp2_update_from_ref <>= module subroutine mci_vamp2_update_from_ref (mci, mci_ref, success) class(mci_vamp2_t), intent(inout) :: mci class(mci_t), intent(in) :: mci_ref logical, intent(out) :: success select type (mci_ref) type is (mci_vamp2_t) call mci%list_pass%update_from_ref (mci_ref%list_pass, success) if (mci%list_pass%has_last_integral()) then call mci%list_pass%get_last_integral( & integral = mci%integral, & error = mci%error, & efficiency = mci%efficiency) mci%integral_known = .true. mci%error_known = .true. mci%efficiency_known = .true. end if end select end subroutine mci_vamp2_update_from_ref @ %def mci_vamp2_update_from_ref @ Update the MCI record (i.e., the integration passes) by reading from input stream. The stream should contain a write output from a previous run. We first check the MD5 sum of the configuration parameters. If that matches, we proceed directly to the stored integration passes. If successful, we may continue to read the file; the position will be after a blank line that must follow the MCI record. <>= procedure, public :: update => mci_vamp2_update <>= module subroutine mci_vamp2_update (mci, u, success) class(mci_vamp2_t), intent(inout) :: mci integer, intent(in) :: u logical, intent(out) :: success end subroutine mci_vamp2_update <>= module subroutine mci_vamp2_update (mci, u, success) class(mci_vamp2_t), intent(inout) :: mci integer, intent(in) :: u logical, intent(out) :: success character(80) :: buffer character(32) :: md5sum_file type(mci_vamp2_t) :: mci_file integer :: n_pass, n_it call read_sval (u, md5sum_file) success = .true.; if (mci%check_grid_file) & & success = (md5sum_file == mci%md5sum) if (success) then read (u, *) read (u, "(A)") buffer if (trim (adjustl (buffer)) /= "VAMP2 integrator:") then call msg_fatal ("VAMP2: reading grid file: corrupted data") end if n_pass = 0 n_it = 0 do read (u, "(A)") buffer select case (trim (adjustl (buffer))) case ("") exit case ("Integration pass:") call mci_file%list_pass%add () call mci_file%list_pass%current%read (u, n_pass, n_it) n_pass = n_pass + 1 n_it = n_it + mci_file%list_pass%current%n_it end select end do call mci%update_from_ref (mci_file, success) call mci_file%final () end if end subroutine mci_vamp2_update @ %def mci_vamp2_update @ Read / write grids from / to file. We split the reading process in two parts. First, we check on the header where we check (and update) all relevant pass data using [[mci_vamp2_update]]. In the second part we only read the integrator data. We implement [[mci_vamp2_read]] for completeness. The writing of the MCI object is split into two parts, a header with the relevant process configuration regarding the integration and the results of the different passes and their iterations. The other part is the actual grid. The header will always be written in ASCII format, including a md5 hash, in order to testify against unwilling changes to the setup. The grid part can be either added to the ASCII file, or to an additional binary file. <>= procedure :: write_grids => mci_vamp2_write_grids procedure :: read_header => mci_vamp2_read_header procedure :: read_data => mci_vamp2_read_data procedure, private :: advance_to_data => mci_vamp2_advance_to_data <>= module subroutine mci_vamp2_write_grids (mci) class(mci_vamp2_t), intent(in) :: mci end subroutine mci_vamp2_write_grids module subroutine mci_vamp2_read_header (mci, success) class(mci_vamp2_t), intent(inout) :: mci logical, intent(out) :: success end subroutine mci_vamp2_read_header module subroutine mci_vamp2_read_data (mci) class(mci_vamp2_t), intent(inout) :: mci end subroutine mci_vamp2_read_data module subroutine mci_vamp2_advance_to_data (mci, u, binary_grid_format) class(mci_vamp2_t), intent(in) :: mci integer, intent(in) :: u logical, intent(out) :: binary_grid_format end subroutine mci_vamp2_advance_to_data <>= module subroutine mci_vamp2_write_grids (mci) class(mci_vamp2_t), intent(in) :: mci integer :: u if (.not. mci%grid_filename_set) then call msg_bug ("VAMP2: write grids: filename undefined") end if if (.not. mci%integrator_defined) then call msg_bug ("VAMP2: write grids: grids undefined") end if open (newunit = u, file = char (mci%get_grid_filename ()), & action = "write", status = "replace") write (u, "(1X,A,A,A)") "MD5sum = '", mci%md5sum, "'" write (u, *) call mci%write (u) write (u, *) if (mci%binary_grid_format) then write (u, "(1X,2A)") "VAMP2 grids: binary file: ", & char (mci%get_grid_filename (binary_grid_format = .true.)) close (u) open (newunit = u, & file = char (mci%get_grid_filename (binary_grid_format = .true.)), & action = "write", & access = "stream", & form = "unformatted", & status = "replace") call mci%integrator%write_binary_grids (u) else write (u, "(1X,A)") "VAMP2 grids:" call mci%integrator%write_grids (u) end if close (u) end subroutine mci_vamp2_write_grids module subroutine mci_vamp2_read_header (mci, success) class(mci_vamp2_t), intent(inout) :: mci logical, intent(out) :: success logical :: exist, binary_grid_format, exist_binary integer :: u success = .false. if (.not. mci%grid_filename_set) then call msg_bug ("VAMP2: read grids: filename undefined") end if !! First, check for existence of the (usual) grid file. inquire (file = char (mci%get_grid_filename ()), exist = exist) if (.not. exist) return !! success = .false. open (newunit = u, file = char (mci%get_grid_filename ()), & action = "read", status = "old") !! Second, check for existence of a (possible) binary grid file. call mci%advance_to_data (u, binary_grid_format) rewind (u) !! Rewind header file, after line search. if (binary_grid_format) then inquire (file = char & (mci%get_grid_filename (binary_grid_format = .true.)), & exist = exist) if (.not. exist) then write (msg_buffer, "(3A)") & "VAMP2: header: binary grid file not found, discarding " // & "grid file '", char (mci%get_grid_filename ()), "'." call msg_message () return !! success = .false. end if end if - !! The grid file (ending *.vg) exists and, if binary file is listed, it + !! The grid file (ending *.vg) exists and, if binary file is listed, it !! exists, too. call mci%update (u, success) close (u) if (.not. success) then write (msg_buffer, "(A,A,A)") & "VAMP2: header: parameter mismatch, discarding pass from file '", & char (mci%get_grid_filename ()), "'." call msg_message () end if end subroutine mci_vamp2_read_header module subroutine mci_vamp2_read_data (mci) class(mci_vamp2_t), intent(inout) :: mci integer :: u logical :: binary_grid_format if (mci%integrator_defined) then call msg_bug ("VAMP2: read grids: grids already defined") end if open (newunit = u, & file = char (mci%get_grid_filename ()), & action = "read", & status = "old") call mci%advance_to_data (u, binary_grid_format) if (binary_grid_format) then close (u) write (msg_buffer, "(3A)") & "VAMP2: Reading from binary grid file '", & char (mci%get_grid_filename (binary_grid_format = .true.)), "'" call msg_message () open (newunit = u, & file = char (mci%get_grid_filename (binary_grid_format = .true.)), & action = "read", & access = "stream", & form = "unformatted", & status = "old") call mci%integrator%read_binary_grids (u) else call mci%integrator%read_grids (u) end if mci%integrator_defined = .true. close (u) end subroutine mci_vamp2_read_data module subroutine mci_vamp2_advance_to_data (mci, u, binary_grid_format) class(mci_vamp2_t), intent(in) :: mci integer, intent(in) :: u logical, intent(out) :: binary_grid_format character(80) :: buffer type(string_t) :: search_string_binary, search_string_ascii search_string_binary = "VAMP2 grids: binary file: " // & mci%get_grid_filename (binary_grid_format = .true.) search_string_ascii = "VAMP2 grids:" SEARCH: do read (u, "(A)") buffer if (trim (adjustl (buffer)) == char (search_string_binary)) then binary_grid_format = .true. exit SEARCH else if (trim (adjustl (buffer)) == char (search_string_ascii)) then binary_grid_format = .false. exit SEARCH end if end do SEARCH end subroutine mci_vamp2_advance_to_data @ %def mci_vamp2_write_grids @ %def mci_vamp2_read_header @ %def mci_vamp2_read_data @ \subsubsection{Interface: VAMP2} \label{sec:interface-vamp2} We define the interfacing procedures, as such, initialising the VAMP2 integrator or resetting the results. Initialise the VAMP2 integrator which is stored within the [[mci]] object, using the data of the current integration pass. Furthermore, reset the counters that track this set of integrator. <>= procedure, public :: init_integrator => mci_vamp2_init_integrator <>= module subroutine mci_vamp2_init_integrator (mci) class(mci_vamp2_t), intent(inout) :: mci end subroutine mci_vamp2_init_integrator <>= module subroutine mci_vamp2_init_integrator (mci) class(mci_vamp2_t), intent(inout) :: mci type (pass_t), pointer :: current integer :: ch, vegas_mode current => mci%list_pass%current vegas_mode = merge (VEGAS_MODE_IMPORTANCE, VEGAS_MODE_IMPORTANCE_ONLY,& & mci%config%stratified) mci%n_adapt_grids = 0 mci%n_adapt_weights = 0 if (mci%integrator_defined) then call msg_bug ("VAMP2: init integrator: & & integrator is already initialised.") end if mci%integrator = vamp2_t (mci%n_channel, mci%n_dim, & & n_bins_max = mci%config%n_bins_max, & & iterations = 1, & & mode = vegas_mode) if (mci%has_chains ()) & call mci%integrator%set_chain (mci%n_chain, mci%chain) call mci%integrator%set_config (mci%config) mci%integrator_defined = .true. end subroutine mci_vamp2_init_integrator @ %def mci_vamp2_init_integrator @ Reset a grid set. Purge the accumulated results. <>= procedure, public :: reset_result => mci_vamp2_reset_result <>= module subroutine mci_vamp2_reset_result (mci) class(mci_vamp2_t), intent(inout) :: mci end subroutine mci_vamp2_reset_result <>= module subroutine mci_vamp2_reset_result (mci) class(mci_vamp2_t), intent(inout) :: mci if (.not. mci%integrator_defined) then call msg_bug ("VAMP2: reset results: integrator undefined") end if call mci%integrator%reset_result () end subroutine mci_vamp2_reset_result @ %def mci_vamp2_reset_result @ Set calls per channel. The number of calls to each channel is defined by the channel weight \begin{equation} \alpha_i = \frac{N_i}{\sum N_i}. \end{equation} <>= procedure, public :: set_calls => mci_vamp2_set_calls <>= module subroutine mci_vamp2_set_calls (mci, n_calls) class(mci_vamp2_t), intent(inout) :: mci integer :: n_calls end subroutine mci_vamp2_set_calls <>= module subroutine mci_vamp2_set_calls (mci, n_calls) class(mci_vamp2_t), intent(inout) :: mci integer :: n_calls if (.not. mci%integrator_defined) then call msg_bug ("VAMP2: set calls: grids undefined") end if call mci%integrator%set_calls (n_calls) end subroutine mci_vamp2_set_calls @ %def mci_vamp2_set_calls \subsubsection{Integration} Initialize. We prepare the integrator from a previous pass, or from file, or with new objects. At the end, we update the number of calls either when we got the integration grids from file and we added new iterations to the current pass, or we allocated a new integrator. <>= procedure, private :: init_integration => mci_vamp2_init_integration <>= module subroutine mci_vamp2_init_integration (mci, n_it, n_calls, instance) class(mci_vamp2_t), intent(inout) :: mci integer, intent(in) :: n_it integer, intent(in) :: n_calls class(mci_instance_t), intent(inout) :: instance end subroutine mci_vamp2_init_integration <>= module subroutine mci_vamp2_init_integration (mci, n_it, n_calls, instance) class(mci_vamp2_t), intent(inout) :: mci integer, intent(in) :: n_it integer, intent(in) :: n_calls class(mci_instance_t), intent(inout) :: instance logical :: from_file, success if (.not. associated (mci%list_pass%current)) then call msg_bug ("MCI integrate: current_pass object not allocated") end if associate (current_pass => mci%list_pass%current) current_pass%integral_defined = .false. mci%config%n_calls_min = mci%config%n_calls_min_per_channel * & mci%config%n_channel call current_pass%configure (n_it, n_calls, mci%config%n_calls_min) mci%adapt_grids = current_pass%adapt_grids mci%adapt_weights = current_pass%adapt_weights mci%pass_complete = .false. mci%it_complete = .false. from_file = .false. if (.not. mci%integrator_defined .or. mci%integrator_from_file) then if (mci%grid_filename_set .and. .not. mci%rebuild) then call mci%read_header (success) from_file = success if (.not. mci%integrator_defined .and. success) & call mci%read_data () end if end if if (from_file) then if (.not. mci%check_grid_file) & & call msg_warning ("Reading grid file: MD5 sum check disabled") call msg_message ("VAMP2: " & // "Using grids and results from file ’" & // char (mci%get_grid_filename ()) // "’.") else if (.not. mci%integrator_defined) then call msg_message ("VAMP2: " & // "Initialize new grids and write to file '" & // char (mci%get_grid_filename ()) // "'.") call mci%init_integrator () end if mci%integrator_from_file = from_file if (.not. mci%integrator_from_file .or. (n_it > current_pass%get_integration_index ())) then call mci%integrator%set_calls (current_pass%n_calls) end if call mci%integrator%set_equivalences (mci%equivalences) end associate <> end subroutine mci_vamp2_init_integration @ %def mci_vamp2_init @ Allocate request object and load into integrator object. <>= if (mci%parallel_method /= "") then call mci%integrator%allocate_request (method = char (mci%parallel_method)) else call msg_message ("VAMP2: Use default parallel method: simple.") call mci%integrator%allocate_request (method = "simple") end if @ Integrate. Perform a new integration pass (possibly reusing previous results), which may consist of several iterations. We reinitialise the sampling new each time and set the workspace again. Note: we record the integral once per iteration. The integral stored in the mci record itself is the last integral of the current iteration, no averaging done. The results record may average results. Note: recording the efficiency is not supported yet. <>= procedure, public :: integrate => mci_vamp2_integrate <>= module subroutine mci_vamp2_integrate (mci, instance, sampler, & n_it, n_calls, results, pacify) class(mci_vamp2_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls class(mci_results_t), intent(inout), optional :: results logical, intent(in), optional :: pacify end subroutine mci_vamp2_integrate <>= module subroutine mci_vamp2_integrate (mci, instance, sampler, & n_it, n_calls, results, pacify) class(mci_vamp2_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls class(mci_results_t), intent(inout), optional :: results logical, intent(in), optional :: pacify integer :: it logical :: from_file, success <> <> call mci%init_integration (n_it, n_calls, instance) from_file = mci%integrator_from_file select type (instance) type is (mci_vamp2_instance_t) call instance%set_workspace (sampler) end select associate (current_pass => mci%list_pass%current) do it = 1, current_pass%n_it if (signal_is_pending ()) return mci%integrator_from_file = from_file .and. & it <= current_pass%get_integration_index () if (.not. mci%integrator_from_file) then mci%it_complete = .false. select type (instance) type is (mci_vamp2_instance_t) call mci%integrator%integrate (instance%func, mci%rng, & & iterations = 1, & & reset_result = .true., & & refine_grids = mci%adapt_grids, & & adapt_weights = mci%adapt_weights, & & verbose = mci%verbose) end select if (signal_is_pending ()) return mci%it_complete = .true. integral = mci%integrator%get_integral () calls = mci%integrator%get_n_calls () select type (instance) type is (mci_vamp2_instance_t) calls_valid = instance%func%get_n_calls () call instance%func%reset_n_calls () end select error = sqrt (mci%integrator%get_variance ()) efficiency = mci%integrator%get_efficiency () <> if (integral /= 0) then current_pass%integral(it) = integral current_pass%calls(it) = calls current_pass%calls_valid(it) = calls_valid current_pass%error(it) = error current_pass%efficiency(it) = efficiency end if current_pass%integral_defined = .true. end if if (present (results)) then if (mci%has_chains ()) then call mci%collect_chain_weights (instance%w) call results%record (1, & n_calls = current_pass%calls(it), & n_calls_valid = current_pass%calls_valid(it), & integral = current_pass%integral(it), & error = current_pass%error(it), & efficiency = current_pass%efficiency(it), & efficiency_pos = current_pass%efficiency(it), & efficiency_neg = 0._default, & chain_weights = mci%chain_weights, & suppress = pacify) else call results%record (1, & n_calls = current_pass%calls(it), & n_calls_valid = current_pass%calls_valid(it), & integral = current_pass%integral(it), & error = current_pass%error(it), & efficiency = current_pass%efficiency(it), & efficiency_pos = current_pass%efficiency(it), & efficiency_neg = 0._default, & suppress = pacify) end if end if if (.not. mci%integrator_from_file & .and. mci%grid_filename_set) then <> call checkpoint_and_write_grids (it = it, & final_it = (it == current_pass%n_it)) end if if (.not. current_pass%is_final_pass) then call check_goals (it, success) if (success) exit end if end do if (signal_is_pending ()) return mci%pass_complete = .true. mci%integral = current_pass%get_integral() mci%error = current_pass%get_error() mci%efficiency = current_pass%get_efficiency() mci%integral_known = .true. mci%error_known = .true. mci%efficiency_known = .true. call mci%compute_md5sum (pacify) end associate contains <> end subroutine mci_vamp2_integrate @ %def mci_vamp2_integrate <>= real(default) :: integral, error, efficiency integer :: calls, calls_valid @ <>= @ <>= @ <>= @ <>= integer :: rank, n_size type(MPI_Request), dimension(6) :: request @ MPI procedure-specific initialization. <>= call MPI_Comm_size (MPI_COMM_WORLD, n_size) call MPI_Comm_rank (MPI_COMM_WORLD, rank) @ We broadcast the current results to all worker, such that they can store them in to the pass list. <>= call MPI_Ibcast (integral, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, request(1)) call MPI_Ibcast (calls, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, request(2)) call MPI_Ibcast (calls_valid, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, request(3)) call MPI_Ibcast (error, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, request(4)) call MPI_Ibcast (efficiency, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, request(5)) call MPI_Waitall (5, request, MPI_STATUSES_IGNORE) @ We only allow the master to write the grids to file. <>= if (rank == 0) & @ Write grids to [[grid_filename]] at a given checkpoint. We qualify each iteration and pass as possible checkpoint. However, we allow the user to alter the checkpoint behavior: \begin{itemize} \item after every iteration, \item after every pass, \item after a \(N\) iterations and every pass. \end{itemize} The user sets the Sindarin variable [[vamp_grid_checkpoint]] to an integer value where the value 0 represents each pass, value 1 each iteration, and a value \(> 1\) means after \(N\) iterations (or at the last iteration of a pass). <>= subroutine checkpoint_and_write_grids (it, final_it) integer, intent(in) :: it logical, intent(in) :: final_it select case (mci%grid_checkpoint) case (0) if (.not. final_it) return case (1) case(2:) if (.not. (final_it & .or. mod (it, mci%grid_checkpoint) == 0)) return case default call msg_bug ("VAMP2: Grid checkpoint must be a positive integer.") end select call mci%write_grids () end subroutine checkpoint_and_write_grids @ Check whether we are already finished with this pass. <>= subroutine check_goals (it, success) integer, intent(in) :: it logical, intent(out) :: success success = .false. associate (current_pass => mci%list_pass%current) if (error_reached (it)) then current_pass%n_it = it call msg_message ("VAMP2: error goal reached; & &skipping iterations") success = .true. return end if if (rel_error_reached (it)) then current_pass%n_it = it call msg_message ("VAMP2: relative error goal reached; & &skipping iterations") success = .true. return end if if (accuracy_reached (it)) then current_pass%n_it = it call msg_message ("VAMP2: accuracy goal reached; & &skipping iterations") success = .true. return end if end associate end subroutine check_goals @ %def mci_vamp2_check_goals @ Return true if the error, relative error or accurary goals hase been reached, if any. <>= function error_reached (it) result (flag) integer, intent(in) :: it logical :: flag real(default) :: error_goal, error error_goal = mci%config%error_goal flag = .false. associate (current_pass => mci%list_pass%current) if (error_goal > 0 .and. current_pass%integral_defined) then error = abs (current_pass%error(it)) flag = error < error_goal end if end associate end function error_reached function rel_error_reached (it) result (flag) integer, intent(in) :: it logical :: flag real(default) :: rel_error_goal, rel_error rel_error_goal = mci%config%rel_error_goal flag = .false. associate (current_pass => mci%list_pass%current) if (rel_error_goal > 0 .and. current_pass%integral_defined) then rel_error = abs (current_pass%error(it) / current_pass%integral(it)) flag = rel_error < rel_error_goal end if end associate end function rel_error_reached function accuracy_reached (it) result (flag) integer, intent(in) :: it logical :: flag real(default) :: accuracy_goal, accuracy accuracy_goal = mci%config%accuracy_goal flag = .false. associate (current_pass => mci%list_pass%current) if (accuracy_goal > 0 .and. current_pass%integral_defined) then if (current_pass%integral(it) /= 0) then accuracy = abs (current_pass%error(it) / current_pass%integral(it)) & * sqrt (real (current_pass%calls(it), default)) flag = accuracy < accuracy_goal else flag = .true. end if end if end associate end function accuracy_reached @ %def error_reached, rel_error_reached, accuracy_reached @ \subsection{Event generation} Prepare simulation. We check the grids and reread them from file, if necessary. <>= procedure, public :: prepare_simulation => mci_vamp2_prepare_simulation <>= module subroutine mci_vamp2_prepare_simulation (mci) class(mci_vamp2_t), intent(inout) :: mci end subroutine mci_vamp2_prepare_simulation <>= module subroutine mci_vamp2_prepare_simulation (mci) class(mci_vamp2_t), intent(inout) :: mci logical :: success if (.not. mci%grid_filename_set) then call msg_bug ("VAMP2: preapre simulation: integrator filename not set.") end if call mci%read_header (success) call mci%compute_md5sum () if (.not. success) then call msg_fatal ("Simulate: " & // "reading integration grids from file ’" & // char (mci%get_grid_filename ()) // "’ failed") end if if (.not. mci%integrator_defined) then call mci%read_data () end if call groom_rng (mci%rng) contains subroutine groom_rng (rng) class(rng_t), intent(inout) :: rng integer :: i, rank, n_size call mpi_get_comm_id (n_size, rank) do i = 2, rank + 1 select type (rng) type is (rng_stream_t) call rng%next_substream () if (i == rank) & call msg_message ("MCI: Advance RNG for parallel event simulation") class default call msg_bug ("Use of any random number generator & &beside rng_stream for parallel event generation not supported.") end select end do end subroutine groom_rng end subroutine mci_vamp2_prepare_simulation @ %def mci_vamp2_prepare_simulation @ Generate an unweighted event. We only set the workspace again before generating an event. <>= procedure, public :: generate_weighted_event => & mci_vamp2_generate_weighted_event <>= module subroutine mci_vamp2_generate_weighted_event (mci, instance, sampler) class(mci_vamp2_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler end subroutine mci_vamp2_generate_weighted_event <>= module subroutine mci_vamp2_generate_weighted_event (mci, instance, sampler) class(mci_vamp2_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler if (.not. mci%integrator_defined) then call msg_bug ("VAMP2: generate weighted event: undefined integrator") end if select type (instance) type is (mci_vamp2_instance_t) instance%event_generated = .false. call instance%set_workspace (sampler) call mci%integrator%generate_weighted (& & instance%func, mci%rng, instance%event_x) instance%event_weight = mci%integrator%get_evt_weight () instance%event_excess = 0 instance%n_events = instance%n_events + 1 instance%event_generated = .true. end select end subroutine mci_vamp2_generate_weighted_event @ %def mci_vamp2_generate_weighted_event @ We apply an additional rescaling factor for [[f_max]] (either for the positive or negative distribution). <>= procedure, public :: generate_unweighted_event => & mci_vamp2_generate_unweighted_event <>= module subroutine mci_vamp2_generate_unweighted_event & (mci, instance, sampler) class(mci_vamp2_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler end subroutine mci_vamp2_generate_unweighted_event <>= module subroutine mci_vamp2_generate_unweighted_event (mci, instance, sampler) class(mci_vamp2_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler if (.not. mci%integrator_defined) then call msg_bug ("VAMP2: generate unweighted event: undefined integrator") end if select type (instance) type is (mci_vamp2_instance_t) instance%event_generated = .false. call instance%set_workspace (sampler) generate: do call mci%integrator%generate_unweighted (& & instance%func, mci%rng, instance%event_x, & & opt_event_rescale = instance%event_rescale_f_max) instance%event_excess = mci%integrator%get_evt_weight_excess () if (signal_is_pending ()) return if (sampler%is_valid ()) exit generate end do generate - if (mci%integrator%get_evt_weight () < 0.) then + if (mci%integrator%get_evt_weight () < 0._default) then if (.not. mci%negative_weights) then call msg_fatal ("VAMP2: cannot sample negative weights!") end if instance%event_weight = -1._default else instance%event_weight = 1._default end if instance%n_events = instance%n_events + 1 instance%event_generated = .true. end select end subroutine mci_vamp2_generate_unweighted_event @ %def mci_vamp2_generate_unweighted_event @ <>= procedure, public :: rebuild_event => mci_vamp2_rebuild_event <>= module subroutine mci_vamp2_rebuild_event (mci, instance, sampler, state) class(mci_vamp2_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state end subroutine mci_vamp2_rebuild_event <>= module subroutine mci_vamp2_rebuild_event (mci, instance, sampler, state) class(mci_vamp2_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state call msg_bug ("VAMP2: rebuild event not implemented yet.") end subroutine mci_vamp2_rebuild_event @ %def mci_vamp2_rebuild_event @ \subsection{Integrator instance} -\label{sec:nistance} +\label{sec:instance} We store all information relevant for simulation. The event weight is stored, when a weighted event is generated, and the event excess, when a larger weight occurs than actual stored max. weight. We give the possibility to rescale the [[f_max]] within the integrator object with [[event_rescale_f_max]]. <>= public :: mci_vamp2_instance_t <>= type, extends (mci_instance_t) :: mci_vamp2_instance_t class(mci_vamp2_func_t), allocatable :: func real(default), dimension(:), allocatable :: gi integer :: n_events = 0 logical :: event_generated = .false. - real(default) :: event_weight = 0. - real(default) :: event_excess = 0. - real(default) :: event_rescale_f_max = 1. + real(default) :: event_weight = 0._default + real(default) :: event_excess = 0._default + real(default) :: event_rescale_f_max = 1._default real(default), dimension(:), allocatable :: event_x contains <> end type mci_vamp2_instance_t @ %def mci_vamp2_instance_t @ Output. <>= procedure, public :: write => mci_vamp2_instance_write <>= module subroutine mci_vamp2_instance_write (object, unit, pacify) class(mci_vamp2_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify end subroutine mci_vamp2_instance_write <>= module subroutine mci_vamp2_instance_write (object, unit, pacify) class(mci_vamp2_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify integer :: u, ch, j character(len=7) :: fmt call pac_fmt (fmt, FMT_17, FMT_14, pacify) u = given_output_unit (unit) write (u, "(1X,A)") "MCI VAMP2 instance:" write (u, "(1X,A,I0)") & & "Selected channel = ", object%selected_channel write (u, "(1X,A25,1X," // fmt // ")") & & "Integrand = ", object%integrand write (u, "(1X,A25,1X," // fmt // ")") & & "MCI weight = ", object%mci_weight write (u, "(1X,A,L1)") & & "Valid = ", object%valid write (u, "(1X,A)") "MCI a-priori weight:" do ch = 1, size (object%w) write (u, "(3X,I25,1X," // fmt // ")") ch, object%w(ch) end do write (u, "(1X,A)") "MCI jacobian:" do ch = 1, size (object%w) write (u, "(3X,I25,1X," // fmt // ")") ch, object%f(ch) end do write (u, "(1X,A)") "MCI mapped x:" do ch = 1, size (object%w) do j = 1, size (object%x, 1) write (u, "(3X,2(1X,I8),1X," // fmt // ")") j, ch, object%x(j, ch) end do end do write (u, "(1X,A)") "MCI channel weight:" do ch = 1, size (object%w) write (u, "(3X,I25,1X," // fmt // ")") ch, object%gi(ch) end do write (u, "(1X,A,I0)") & & "Number of event = ", object%n_events write (u, "(1X,A,L1)") & & "Event generated = ", object%event_generated write (u, "(1X,A25,1X," // fmt // ")") & & "Event weight = ", object%event_weight write (u, "(1X,A25,1X," // fmt // ")") & & "Event excess = ", object%event_excess write (u, "(1X,A25,1X," // fmt // ")") & & "Event rescale f max = ", object%event_rescale_f_max write (u, "(1X,A,L1)") & & "Negative (event) weight = ", object%negative_weights write (u, "(1X,A)") "MCI event" do j = 1, size (object%event_x) write (u, "(3X,I25,1X," // fmt // ")") j, object%event_x(j) end do end subroutine mci_vamp2_instance_write @ %def mci_vamp2_instance_write @ Finalizer. We are only using allocatable, so there is nothing to do here. <>= procedure, public :: final => mci_vamp2_instance_final <>= module subroutine mci_vamp2_instance_final (object) class(mci_vamp2_instance_t), intent(inout) :: object end subroutine mci_vamp2_instance_final <>= module subroutine mci_vamp2_instance_final (object) class(mci_vamp2_instance_t), intent(inout) :: object ! end subroutine mci_vamp2_instance_final @ %def mci_vamp2_instance_final @ Initializer. Gfortran 7/8/9 bug, has to remain in the main module: <>= procedure, public :: init => mci_vamp2_instance_init <>= subroutine mci_vamp2_instance_init (mci_instance, mci) class(mci_vamp2_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci call mci_instance%base_init (mci) allocate (mci_instance%gi(mci%n_channel), source=0._default) allocate (mci_instance%event_x(mci%n_dim), source=0._default) allocate (mci_vamp2_func_t :: mci_instance%func) call mci_instance%func%init (n_dim = mci%n_dim, n_channel = mci%n_channel) end subroutine mci_vamp2_instance_init @ %def mci_vamp2_instance_init @ Set workspace for [[mci_vamp2_func_t]]. <>= procedure, public :: set_workspace => mci_vamp2_instance_set_workspace <>= module subroutine mci_vamp2_instance_set_workspace (instance, sampler) class(mci_vamp2_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler end subroutine mci_vamp2_instance_set_workspace <>= module subroutine mci_vamp2_instance_set_workspace (instance, sampler) class(mci_vamp2_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler call instance%func%set_workspace (instance, sampler) end subroutine mci_vamp2_instance_set_workspace @ %def mci_vmp2_instance_set_workspace @ \subsubsection{Evaluation} Compute multi-channel weight. The computation of the multi-channel weight is done by the VAMP2 function. We retrieve the information. <>= procedure, public :: compute_weight => mci_vamp2_instance_compute_weight <>= module subroutine mci_vamp2_instance_compute_weight (mci, c) class(mci_vamp2_instance_t), intent(inout) :: mci integer, intent(in) :: c end subroutine mci_vamp2_instance_compute_weight <>= module subroutine mci_vamp2_instance_compute_weight (mci, c) class(mci_vamp2_instance_t), intent(inout) :: mci integer, intent(in) :: c mci%gi = mci%func%get_probabilities () mci%mci_weight = mci%func%get_weight () end subroutine mci_vamp2_instance_compute_weight @ %def mci_vamp2_instance_compute_weight @ Record the integrand. <>= procedure, public :: record_integrand => mci_vamp2_instance_record_integrand <>= module subroutine mci_vamp2_instance_record_integrand (mci, integrand) class(mci_vamp2_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand end subroutine mci_vamp2_instance_record_integrand <>= module subroutine mci_vamp2_instance_record_integrand (mci, integrand) class(mci_vamp2_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand mci%integrand = integrand call mci%func%set_integrand (integrand) end subroutine mci_vamp2_instance_record_integrand @ %def mci_vamp2_instance_record_integrand @ \subsubsection{Event simulation} In contrast to VAMP, we reset only counters and set the safety factor, which will then will be applied each time an event is generated. In that way we do not rescale the actual values in the integrator, but more the current value! <>= procedure, public :: init_simulation => mci_vamp2_instance_init_simulation <>= module subroutine mci_vamp2_instance_init_simulation & (instance, safety_factor) class(mci_vamp2_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor end subroutine mci_vamp2_instance_init_simulation <>= module subroutine mci_vamp2_instance_init_simulation (instance, safety_factor) class(mci_vamp2_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor if (present (safety_factor)) instance%event_rescale_f_max = safety_factor instance%n_events = 0 instance%event_generated = .false. if (instance%event_rescale_f_max /= 1) then write (msg_buffer, "(A,ES10.3,A)") "Simulate: & &applying safety factor ", instance%event_rescale_f_max, & & " to event rejection." call msg_message () end if end subroutine mci_vamp2_instance_init_simulation @ %def mci_vamp2_instance_init_simulation @ <>= procedure, public :: final_simulation => mci_vamp2_instance_final_simulation <>= module subroutine mci_vamp2_instance_final_simulation (instance) class(mci_vamp2_instance_t), intent(inout) :: instance end subroutine mci_vamp2_instance_final_simulation <>= module subroutine mci_vamp2_instance_final_simulation (instance) class(mci_vamp2_instance_t), intent(inout) :: instance ! end subroutine mci_vamp2_instance_final_simulation @ %def mci_vamp2_instance_final @ <>= procedure, public :: get_event_weight => mci_vamp2_instance_get_event_weight <>= module function mci_vamp2_instance_get_event_weight (mci) result (weight) class(mci_vamp2_instance_t), intent(in) :: mci real(default) :: weight end function mci_vamp2_instance_get_event_weight <>= module function mci_vamp2_instance_get_event_weight (mci) result (weight) class(mci_vamp2_instance_t), intent(in) :: mci real(default) :: weight if (.not. mci%event_generated) then call msg_bug ("VAMP2: get event weight: no event generated") end if weight = mci%event_weight end function mci_vamp2_instance_get_event_weight @ %def mci_vamp2_instance_get_event_weight @ <>= procedure, public :: get_event_excess => mci_vamp2_instance_get_event_excess <>= module function mci_vamp2_instance_get_event_excess (mci) result (excess) class(mci_vamp2_instance_t), intent(in) :: mci real(default) :: excess end function mci_vamp2_instance_get_event_excess <>= module function mci_vamp2_instance_get_event_excess (mci) result (excess) class(mci_vamp2_instance_t), intent(in) :: mci real(default) :: excess if (.not. mci%event_generated) then call msg_bug ("VAMP2: get event excess: no event generated") end if excess = mci%event_excess end function mci_vamp2_instance_get_event_excess @ %def mci_vamp2_instance_get_event_excess @ \clearpage \subsection{Unit tests} \label{sec:mic-vamp2-ut} Test module, followed by the corresponding implementation module. <<[[mci_vamp2_ut.f90]]>>= <> module mci_vamp2_ut use unit_tests use mci_vamp2_uti <> <> contains <> end module mci_vamp2_ut @ %def mci_vamp2_ut @ <<[[mci_vamp2_uti.f90]]>>= <> module mci_vamp2_uti <> <> use io_units use constants, only: PI, TWOPI use rng_base use rng_tao use rng_stream use mci_base use mci_vamp2 <> <> <> contains <> end module mci_vamp2_uti @ %def mci_vamp2_uti @ API: driver for the unit tests below. <>= public :: mci_vamp2_test <>= subroutine mci_vamp2_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine mci_vamp2_test @ %def mci_vamp2_test @ \subsubsection{Test sampler} \label{sec:mci-vamp2-test-sampler} A test sampler object should implement a function with known integral that we can use to check the integrator. In mode [[1]], the function is $f(x) = 3 x^2$ with integral $\int_0^1 f(x)\,dx=1$ and maximum $f(1)=3$. If the integration dimension is greater than one, the function is extended as a constant in the other dimension(s). In mode [[2]], the function is $11 x^{10}$, also with integral $1$. Mode [[4]] includes ranges of zero and negative function value, the integral is negative. The results should be identical to the results of [[mci_midpoint_4]], where the same function is evaluated. The function is $f(x) = (1 - 3 x^2)\,\theta(x-1/2)$ with integral $\int_0^1 f(x)\,dx=-3/8$, minimum $f(1)=-2$ and maximum $f(1/2)=1/4$. <>= type, extends (mci_sampler_t) :: test_sampler_1_t real(default), dimension(:), allocatable :: x real(default) :: val integer :: mode = 1 contains <> end type test_sampler_1_t @ %def test_sampler_1_t @ Output: There is nothing stored inside, so just print an informative line. <>= procedure, public :: write => test_sampler_1_write <>= subroutine test_sampler_1_write (object, unit, testflag) class(test_sampler_1_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) select case (object%mode) case (1) write (u, "(1x,A)") "Test sampler: f(x) = 3 x^2" case (2) write (u, "(1x,A)") "Test sampler: f(x) = 11 x^10" case (3) write (u, "(1x,A)") "Test sampler: f(x) = 11 x^10 * 2 * cos^2 (2 pi y)" case (4) write (u, "(1x,A)") "Test sampler: f(x) = (1 - 3 x^2) theta(x - 1/2)" end select end subroutine test_sampler_1_write @ %def test_sampler_1_write @ Evaluation: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure, public :: evaluate => test_sampler_1_evaluate <>= subroutine test_sampler_1_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_1_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f if (allocated (sampler%x)) deallocate (sampler%x) allocate (sampler%x (size (x_in))) sampler%x = x_in select case (sampler%mode) case (1) sampler%val = 3 * x_in(1) ** 2 case (2) sampler%val = 11 * x_in(1) ** 10 case (3) sampler%val = 11 * x_in(1) ** 10 * 2 * cos (twopi * x_in(2)) ** 2 case (4) if (x_in(1) >= .5_default) then sampler%val = 1 - 3 * x_in(1) ** 2 else sampler%val = 0 end if end select call sampler%fetch (val, x, f) end subroutine test_sampler_1_evaluate @ %def test_sampler_1_evaluate @ The point is always valid. <>= procedure, public :: is_valid => test_sampler_1_is_valid <>= function test_sampler_1_is_valid (sampler) result (valid) class(test_sampler_1_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_1_is_valid @ %def test_sampler_1_is_valid @ Rebuild: compute all but the function value. <>= procedure, public :: rebuild => test_sampler_1_rebuild <>= subroutine test_sampler_1_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_1_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f if (allocated (sampler%x)) deallocate (sampler%x) allocate (sampler%x (size (x_in))) sampler%x = x_in sampler%val = val x(:,1) = sampler%x f = 1 end subroutine test_sampler_1_rebuild @ %def test_sampler_1_rebuild @ Extract the results. <>= procedure, public :: fetch => test_sampler_1_fetch <>= subroutine test_sampler_1_fetch (sampler, val, x, f) class(test_sampler_1_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x(:,1) = sampler%x f = 1 end subroutine test_sampler_1_fetch @ %def test_sampler_1_fetch @ \subsubsection{Two-channel, two dimension test sampler} This sampler implements the function \begin{equation} f(x, y) = 4\sin^2(\pi x)\sin^2(\pi y) + 2\sin^2(\pi v) \end{equation} where \begin{align} x &= u^v &u &= xy \\ y &= u^{(1-v)} &v &= \frac12\left(1 + \frac{\log(x/y)}{\log xy}\right) \end{align} Each term contributes $1$ to the integral. The first term in the function is peaked along a cross aligned to the coordinates $x$ and $y$, while the second term is peaked along the diagonal $x=y$. The Jacobian is \begin{equation} \frac{\partial(x,y)}{\partial(u,v)} = |\log u| \end{equation} <>= type, extends (mci_sampler_t) :: test_sampler_2_t real(default), dimension(:,:), allocatable :: x real(default), dimension(:), allocatable :: f real(default) :: val contains <> end type test_sampler_2_t @ %def test_sampler_2_t @ Output: There is nothing stored inside, so just print an informative line. <>= procedure, public :: write => test_sampler_2_write <>= subroutine test_sampler_2_write (object, unit, testflag) class(test_sampler_2_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Two-channel test sampler 2" end subroutine test_sampler_2_write @ %def test_sampler_2_write @ Kinematics: compute $x$ and Jacobians, given the input parameter array. <>= procedure, public :: compute => test_sampler_2_compute <>= subroutine test_sampler_2_compute (sampler, c, x_in) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default) :: xx, yy, uu, vv if (.not. allocated (sampler%x)) & allocate (sampler%x (size (x_in), 2)) if (.not. allocated (sampler%f)) & allocate (sampler%f (2)) select case (c) case (1) xx = x_in(1) yy = x_in(2) uu = xx * yy vv = (1 + log (xx/yy) / log (xx*yy)) / 2 case (2) uu = x_in(1) vv = x_in(2) xx = uu ** vv yy = uu ** (1 - vv) end select sampler%val = (2 * sin (pi * xx) * sin (pi * yy)) ** 2 & + 2 * sin (pi * vv) ** 2 sampler%f(1) = 1 sampler%f(2) = abs (log (uu)) sampler%x(:,1) = [xx, yy] sampler%x(:,2) = [uu, vv] end subroutine test_sampler_2_compute @ %def test_sampler_kinematics @ Evaluation: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure, public :: evaluate => test_sampler_2_evaluate <>= subroutine test_sampler_2_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) call sampler%fetch (val, x, f) end subroutine test_sampler_2_evaluate @ %def test_sampler_2_evaluate @ The point is always valid. <>= procedure, public :: is_valid => test_sampler_2_is_valid <>= function test_sampler_2_is_valid (sampler) result (valid) class(test_sampler_2_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_2_is_valid @ %def test_sampler_2_is_valid @ Rebuild: compute all but the function value. <>= procedure, public :: rebuild => test_sampler_2_rebuild <>= subroutine test_sampler_2_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) x = sampler%x f = sampler%f end subroutine test_sampler_2_rebuild @ %def test_sampler_2_rebuild @ Extract the results. <>= procedure, public :: fetch => test_sampler_2_fetch <>= subroutine test_sampler_2_fetch (sampler, val, x, f) class(test_sampler_2_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x = sampler%x f = sampler%f end subroutine test_sampler_2_fetch @ %def test_sampler_2_fetch @ \subsubsection{One-dimensional integration} \label{sec:mci-vamp2-one-dim} Construct an integrator and use it for a one-dimensional sampler. <>= call test (mci_vamp2_1, "mci_vamp2_1", "one-dimensional integral", u, results) <>= public :: mci_vamp2_1 <>= subroutine mci_vamp2_1 (u) integer, intent(in) :: u type(mci_vamp2_config_t) :: config class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable, target :: mci_sampler class(rng_t), allocatable :: rng type(string_t) :: filename write (u, "(A)") "* Test output: mci_vamp2_1" write (u, "(A)") "* Purpose: integrate function in one dimension (single channel)" write (u, "(A)") write (u, "(A)") "* Initialise integrator" write (u, "(A)") allocate (mci_vamp2_t :: mci) call mci%set_dimensions (1, 1) filename = "mci_vamp2_1" select type (mci) type is (mci_vamp2_t) call mci%set_config (config) call mci%set_grid_filename (filename) end select allocate (rng_stream_t :: rng) call rng%init () call mci%import_rng (rng) call mci%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Initialise instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") write (u, "(A)") "* Initialise test sampler" write (u, "(A)") allocate (test_sampler_1_t :: mci_sampler) call mci_sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_calls = 1000" write (u, "(A)") " (lower precision to avoid" write (u, "(A)") " numerical noise)" write (u, "(A)") select type (mci) type is (mci_vamp2_t) call mci%add_pass () end select call mci%integrate (mci_instance, mci_sampler, 1, 1000, pacify = .true.) call mci%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Dump channel weights and grids to file" write (u, "(A)") mci%md5sum = "1234567890abcdef1234567890abcdef" select type (mci) type is (mci_vamp2_t) call mci%write_grids () end select write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp2_1" end subroutine mci_vamp2_1 @ %def mci_vamp2_test1 @ \subsubsection{Multiple iterations} Construct an integrator and use it for a one-dimensional sampler. Integrate with five iterations without grid adaptation. <>= call test (mci_vamp2_2, "mci_vamp2_2", & "multiple iterations", & u, results) <>= public :: mci_vamp2_2 <>= subroutine mci_vamp2_2 (u) type(mci_vamp2_config_t) :: config integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng type(string_t) :: filename write (u, "(A)") "* Test output: mci_vamp2_2" write (u, "(A)") "* Purpose: integrate function in one dimension & &(single channel), but multiple iterations." write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp2_t :: mci) call mci%set_dimensions (1, 1) filename = "mci_vamp2_2" select type (mci) type is (mci_vamp2_t) call mci%set_config (config) call mci%set_grid_filename (filename) end select allocate (rng_stream_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_1_t :: sampler) select type (sampler) type is (test_sampler_1_t) sampler%mode = 2 end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 100" write (u, "(A)") select type (mci) type is (mci_vamp2_t) call mci%add_pass (adapt_grids = .false.) end select call mci%integrate (mci_instance, sampler, 3, 1000, pacify = .true.) call mci%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Dump channel weights and grids to file" write (u, "(A)") mci%md5sum = "1234567890abcdef1234567890abcdef" select type (mci) type is (mci_vamp2_t) call mci%write_grids () end select write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp2_2" end subroutine mci_vamp2_2 @ %def mci_vamp2_2 @ \subsubsection{Grid adaptation} Construct an integrator and use it for a one-dimensional sampler. Integrate with three iterations and in-between grid adaptations. <>= call test (mci_vamp2_3, "mci_vamp2_3", & "grid adaptation", & u, results) <>= public :: mci_vamp2_3 <>= subroutine mci_vamp2_3 (u) integer, intent(in) :: u type(mci_vamp2_config_t) :: config class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng type(string_t) :: filename write (u, "(A)") "* Test output: mci_vamp2_3" write (u, "(A)") "* Purpose: integrate function in one dimension & &(single channel)" write (u, "(A)") "* and adapt grid" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp2_t :: mci) call mci%set_dimensions (1, 1) filename = "mci_vamp2_3" select type (mci) type is (mci_vamp2_t) call mci%set_grid_filename (filename) call mci%set_config (config) end select allocate (rng_stream_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_1_t :: sampler) select type (sampler) type is (test_sampler_1_t) sampler%mode = 2 end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 100" write (u, "(A)") select type (mci) type is (mci_vamp2_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000, pacify = .true.) call mci%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Dump channel weights and grids to file" write (u, "(A)") mci%md5sum = "1234567890abcdef1234567890abcdef" select type (mci) type is (mci_vamp2_t) call mci%write_grids () end select write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp2_3" end subroutine mci_vamp2_3 @ %def mci_vamp2_3 @ \section{Dispatch} @ <<[[dispatch_mci.f90]]>>= <> module dispatch_mci <> use variables use mci_base <> <> interface <> end interface end module dispatch_mci @ %def dispatch_mci @ <<[[dispatch_mci_sub.f90]]>>= <> submodule (dispatch_mci) dispatch_mci_s use diagnostics use os_interface use mci_none use mci_midpoint use mci_vamp use mci_vamp2 implicit none <> contains <> end submodule dispatch_mci_s @ %def dispatch_mci_s @ Allocate an integrator according to the variable [[$integration_method]]. <>= public :: dispatch_mci_setup <>= module subroutine dispatch_mci_setup (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_setup <>= module subroutine dispatch_mci_setup (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 type(string_t) :: run_id type(string_t) :: integration_method type(grid_parameters_t) :: grid_par type(history_parameters_t) :: history_par type(mci_vamp2_config_t) :: mci_vamp2_config integer :: grid_checkpoint logical :: rebuild_grids, check_grid_file, negative_weights, verbose logical :: dispatch_nlo, binary_grid_format type(string_t) :: grid_path, parallel_method dispatch_nlo = .false.; if (present (is_nlo)) dispatch_nlo = is_nlo integration_method = & var_list%get_sval (var_str ("$integration_method")) select case (char (integration_method)) case ("none") allocate (mci_none_t :: mci) case ("midpoint") allocate (mci_midpoint_t :: mci) case ("vamp", "default") call unpack_options_vamp () allocate (mci_vamp_t :: mci) select type (mci) type is (mci_vamp_t) call mci%set_grid_parameters (grid_par) if (run_id /= "") then call mci%set_grid_filename (process_id, run_id) else call mci%set_grid_filename (process_id) end if grid_path = var_list%get_sval (var_str ("$integrate_workspace")) if (grid_path /= "") then call setup_grid_path (grid_path) call mci%prepend_grid_path (grid_path) end if call mci%set_history_parameters (history_par) call mci%set_rebuild_flag (rebuild_grids, check_grid_file) mci%negative_weights = negative_weights mci%verbose = verbose end select case ("vamp2") call unpack_options_vamp2 () allocate (mci_vamp2_t :: mci) select type (mci) type is (mci_vamp2_t) call mci%set_config (mci_vamp2_config) if (run_id /= "") then call mci%set_grid_filename (process_id, run_id) else call mci%set_grid_filename (process_id) end if grid_path = var_list%get_sval (var_str ("$integrate_workspace")) if (grid_path /= "") then call setup_grid_path (grid_path) call mci%prepend_grid_path (grid_path) end if call mci%set_rebuild_flag (rebuild_grids, check_grid_file) mci%negative_weights = negative_weights mci%verbose = verbose mci%grid_checkpoint = grid_checkpoint mci%binary_grid_format = binary_grid_format mci%parallel_method = parallel_method end select case default call msg_fatal ("Integrator '" & // char (integration_method) // "' not implemented") end select contains <> end subroutine dispatch_mci_setup @ %def dispatch_mci_setup @ <>= subroutine unpack_options_vamp () grid_par%threshold_calls = & var_list%get_ival (var_str ("threshold_calls")) grid_par%min_calls_per_channel = & var_list%get_ival (var_str ("min_calls_per_channel")) grid_par%min_calls_per_bin = & var_list%get_ival (var_str ("min_calls_per_bin")) grid_par%min_bins = & var_list%get_ival (var_str ("min_bins")) grid_par%max_bins = & var_list%get_ival (var_str ("max_bins")) grid_par%stratified = & var_list%get_lval (var_str ("?stratified")) select case (char (var_list%get_sval (var_str ("$phs_method")))) case ("rambo") grid_par%use_vamp_equivalences = .false. case default grid_par%use_vamp_equivalences = & var_list%get_lval (var_str ("?use_vamp_equivalences")) end select grid_par%channel_weights_power = & var_list%get_rval (var_str ("channel_weights_power")) grid_par%accuracy_goal = & var_list%get_rval (var_str ("accuracy_goal")) grid_par%error_goal = & var_list%get_rval (var_str ("error_goal")) grid_par%rel_error_goal = & var_list%get_rval (var_str ("relative_error_goal")) history_par%global = & var_list%get_lval (var_str ("?vamp_history_global")) history_par%global_verbose = & var_list%get_lval (var_str ("?vamp_history_global_verbose")) history_par%channel = & var_list%get_lval (var_str ("?vamp_history_channels")) history_par%channel_verbose = & var_list%get_lval (var_str ("?vamp_history_channels_verbose")) verbose = & var_list%get_lval (var_str ("?vamp_verbose")) check_grid_file = & var_list%get_lval (var_str ("?check_grid_file")) run_id = & var_list%get_sval (var_str ("$run_id")) rebuild_grids = & var_list%get_lval (var_str ("?rebuild_grids")) negative_weights = & var_list%get_lval (var_str ("?negative_weights")) .or. dispatch_nlo end subroutine unpack_options_vamp subroutine unpack_options_vamp2 () mci_vamp2_config%n_bins_max = & var_list%get_ival (var_str ("max_bins")) mci_vamp2_config%n_calls_min_per_channel = & var_list%get_ival (var_str ("min_calls_per_channel")) mci_vamp2_config%n_calls_threshold = & var_list%get_ival (var_str ("threshold_calls")) mci_vamp2_config%beta = & var_list%get_rval (var_str ("channel_weights_power")) mci_vamp2_config%stratified = & var_list%get_lval (var_str ("?stratified")) select case (char (var_list%get_sval (var_str ("$phs_method")))) case ("rambo") mci_vamp2_config%equivalences = .false. case default mci_vamp2_config%equivalences = & var_list%get_lval (var_str ("?use_vamp_equivalences")) end select mci_vamp2_config%accuracy_goal = & var_list%get_rval (var_str ("accuracy_goal")) mci_vamp2_config%error_goal = & var_list%get_rval (var_str ("error_goal")) mci_vamp2_config%rel_error_goal = & var_list%get_rval (var_str ("relative_error_goal")) verbose = & var_list%get_lval (var_str ("?vamp_verbose")) check_grid_file = & var_list%get_lval (var_str ("?check_grid_file")) run_id = & var_list%get_sval (var_str ("$run_id")) rebuild_grids = & var_list%get_lval (var_str ("?rebuild_grids")) negative_weights = & var_list%get_lval (var_str ("?negative_weights")) .or. dispatch_nlo grid_checkpoint = & var_list%get_ival (var_str ("vamp_grid_checkpoint")) select case (char (var_list%get_sval (var_str ("$vamp_grid_format")))) case ("binary","Binary","BINARY") binary_grid_format = .true. case ("ascii","Ascii","ASCII") binary_grid_format = .false. case default binary_grid_format = .false. end select select case (char (var_list%get_sval (var_str ("$vamp_parallel_method")))) case ("simple","Simple","SIMPLE") parallel_method = var_str ("simple") case ("load","Load","LOAD") parallel_method = var_str ("load") case default parallel_method = var_str ("simple") end select end subroutine unpack_options_vamp2 @ @ Make sure that the VAMP grid subdirectory, if requested, exists before it is used. Also include a sanity check on the directory name. <>= character(*), parameter :: ALLOWED_IN_DIRNAME = & "abcdefghijklmnopqrstuvwxyz& &ABCDEFGHIJKLMNOPQRSTUVWXYZ& &1234567890& &.,_-+=" @ %def ALLOWED_IN_DIRNAME <>= public :: setup_grid_path <>= module subroutine setup_grid_path (grid_path) type(string_t), intent(in) :: grid_path end subroutine setup_grid_path <>= module subroutine setup_grid_path (grid_path) type(string_t), intent(in) :: grid_path if (verify (grid_path, ALLOWED_IN_DIRNAME) == 0) then call msg_message ("Integrator: preparing VAMP grid directory '" & // char (grid_path) // "'") call os_system_call ("mkdir -p '" // grid_path // "'") else call msg_fatal ("Integrator: VAMP grid_path '" & // char (grid_path) // "' contains illegal characters") end if end subroutine setup_grid_path @ %def setup_grid_path @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[dispatch_mci_ut.f90]]>>= <> module dispatch_mci_ut use unit_tests use dispatch_mci_uti <> <> contains <> end module dispatch_mci_ut @ %def dispatch_mci_ut @ <<[[dispatch_mci_uti.f90]]>>= <> module dispatch_mci_uti <> <> use variables use mci_base use mci_none use mci_midpoint use mci_vamp use dispatch_mci <> <> contains <> end module dispatch_mci_uti @ %def dispatch_mci_ut @ API: driver for the unit tests below. <>= public ::dispatch_mci_test <>= subroutine dispatch_mci_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine dispatch_mci_test @ %def dispatch_mci_test @ \subsubsection{Select type: integrator core} <>= call test (dispatch_mci_1, "dispatch_mci_1", & "integration method", & u, results) <>= public :: dispatch_mci_1 <>= subroutine dispatch_mci_1 (u) integer, intent(in) :: u type(var_list_t) :: var_list class(mci_t), allocatable :: mci type(string_t) :: process_id write (u, "(A)") "* Test output: dispatch_mci_1" write (u, "(A)") "* Purpose: select integration method" write (u, "(A)") call var_list%init_defaults (0) process_id = "dispatch_mci_1" write (u, "(A)") "* Allocate MCI as none_t" write (u, "(A)") call var_list%set_string (& var_str ("$integration_method"), & var_str ("none"), is_known = .true.) call dispatch_mci_setup (mci, var_list, process_id) select type (mci) type is (mci_none_t) call mci%write (u) end select call mci%final () deallocate (mci) write (u, "(A)") write (u, "(A)") "* Allocate MCI as midpoint_t" write (u, "(A)") call var_list%set_string (& var_str ("$integration_method"), & var_str ("midpoint"), is_known = .true.) call dispatch_mci_setup (mci, var_list, process_id) select type (mci) type is (mci_midpoint_t) call mci%write (u) end select call mci%final () deallocate (mci) write (u, "(A)") write (u, "(A)") "* Allocate MCI as vamp_t" write (u, "(A)") call var_list%set_string (& var_str ("$integration_method"), & var_str ("vamp"), is_known = .true.) call var_list%set_int (var_str ("threshold_calls"), & 1, is_known = .true.) call var_list%set_int (var_str ("min_calls_per_channel"), & 2, is_known = .true.) call var_list%set_int (var_str ("min_calls_per_bin"), & 3, is_known = .true.) call var_list%set_int (var_str ("min_bins"), & 4, is_known = .true.) call var_list%set_int (var_str ("max_bins"), & 5, is_known = .true.) call var_list%set_log (var_str ("?stratified"), & .false., is_known = .true.) call var_list%set_log (var_str ("?use_vamp_equivalences"),& .false., is_known = .true.) call var_list%set_real (var_str ("channel_weights_power"),& 4._default, is_known = .true.) call var_list%set_log (& var_str ("?vamp_history_global_verbose"), & .true., is_known = .true.) call var_list%set_log (& var_str ("?vamp_history_channels"), & .true., is_known = .true.) call var_list%set_log (& var_str ("?vamp_history_channels_verbose"), & .true., is_known = .true.) call var_list%set_log (var_str ("?stratified"), & .false., is_known = .true.) call dispatch_mci_setup (mci, var_list, process_id) select type (mci) type is (mci_vamp_t) call mci%write (u) call mci%write_history_parameters (u) end select call mci%final () deallocate (mci) write (u, "(A)") write (u, "(A)") "* Allocate MCI as vamp_t, allow for negative weights" write (u, "(A)") call var_list%set_string (& var_str ("$integration_method"), & var_str ("vamp"), is_known = .true.) call var_list%set_log (var_str ("?negative_weights"), & .true., is_known = .true.) call dispatch_mci_setup (mci, var_list, process_id) select type (mci) type is (mci_vamp_t) call mci%write (u) call mci%write_history_parameters (u) end select call mci%final () deallocate (mci) call var_list%final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_mci_1" end subroutine dispatch_mci_1 @ %def dispatch_mci_1 Index: trunk/src/process_integration/process_integration.nw =================================================================== --- trunk/src/process_integration/process_integration.nw (revision 8827) +++ trunk/src/process_integration/process_integration.nw (revision 8828) @@ -1,23920 +1,23918 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: integration and process objects and such %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Integration and Process Objects} \includemodulegraph{process_integration} This is the central part of the \whizard\ package. It provides the functionality for evaluating structure functions, kinematics and matrix elements, integration and event generation. It combines the various parts that deal with those tasks individually and organizes the data transfer between them. \begin{description} \item[subevt\_expr] This enables process observables as (abstract) expressions, to be evaluated for each process call. \item[parton\_states] A [[parton_state_t]] object represents an elementary partonic interaction. There are two versions: one for the isolated elementary process, one for the elementary process convoluted with the structure-function chain. The parton state is an effective state. It needs not coincide with the seed-kinematics state which is used in evaluating phase space. \item[process] Here, all pieces are combined for the purpose of evaluating the elementary processes. The whole algorithm is coded in terms of abstract data types as defined in the appropriate modules: [[prc_core]] for matrix-element evaluation, [[prc_core_def]] for the associated configuration and driver, [[sf_base]] for beams and structure-functions, [[phs_base]] for phase space, and [[mci_base]] for integration and event generation. \item[process\_config] \item[process\_counter] Very simple object for statistics \item[process\_mci] \item[pcm] \item[kinematics] \item[instances] While the above modules set up all static information, the instances have the changing event data. There are term and process instances but no component instances. \item[process\_stacks] Process stacks collect process objects. \end{description} We combine here hard interactions, phase space, and (for scatterings) structure functions and interfaces them to the integration module. The process object implements the combination of a fixed beam and structure-function setup with a number of elementary processes. The latter are called process components. The process object represents an entity which is supposedly observable. It should be meaningful to talk about the cross section of a process. The individual components of a process are, technically, processes themselves, but they may have unphysical cross sections which have to be added for a physical result. Process components may be exclusive tree-level elementary processes, dipole subtraction term, loop corrections, etc. The beam and structure function setup is common to all process components. Thus, there is only one instance of this part. The process may be a scattering process or a decay process. In the latter case, there are no structure functions, and the beam setup consists of a single particle. Otherwise, the two classes are treated on the same footing. Once a sampling point has been chosen, a process determines a set of partons with a correlated density matrix of quantum numbers. In general, each sampling point will generate, for each process component, one or more distinct parton configurations. This is the [[computed]] state. The computed state is the subject of the multi-channel integration algorithm. For NLO computations, it is necessary to project the computed states onto another set of parton configurations (e.g., by recombining certain pairs). This is the [[observed]] state. When computing partonic observables, the information is taken from the observed state. For the purpose of event generation, we will later select one parton configuration from the observed state and collapse the correlated quantum state. This configuration is then dressed by applying parton shower, decays and hadronization. The decay chain, in particular, combines a scattering process with possible subsequent decay processes on the parton level, which are full-fledged process objects themselves. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process observables} We define an abstract [[subevt_expr_t]] object as an extension of the [[subevt_t]] type. The object contains a local variable list, variable instances (as targets for pointers in the variable list), and evaluation trees. The evaluation trees reference both the variables and the [[subevt]]. There are two instances of the abstract type: one for process instances, one for physical events. Both have a common logical expression [[selection]] which determines whether the object passes user-defined cuts. The intention is that we fill the [[subevt_t]] base object and compute the variables once we have evaluated a kinematical phase space point (or a complete event). We then evaluate the expressions and can use the results in further calculations. The [[process_expr_t]] extension contains furthermore scale and weight expressions. The [[event_expr_t]] extension contains a reweighting-factor expression and a logical expression for event analysis. In practice, we will link the variable list of the [[event_obs]] object to the variable list of the currently active [[process_obs]] object, such that the process variables are available to both objects. Event variables are meaningful only for physical events. Note that there are unit tests, but they are deferred to the [[expr_tests]] module. <<[[subevt_expr.f90]]>>= <> module subevt_expr <> <> use lorentz use subevents use variables use flavors use quantum_numbers use interactions use particles use expr_base <> <> <> <> interface <> end interface end module subevt_expr @ %def subevt_expr @ <<[[subevt_expr_sub.f90]]>>= <> submodule (subevt_expr) subevt_expr_s use constants, only: zero, one use io_units use format_utils, only: write_separator use diagnostics implicit none contains <> end submodule subevt_expr_s @ %def subevt_expr_s @ \subsection{Abstract base type} <>= type, extends (subevt_t), abstract :: subevt_expr_t logical :: subevt_filled = .false. type(var_list_t) :: var_list real(default) :: sqrts_hat = 0 integer :: n_in = 0 integer :: n_out = 0 integer :: n_tot = 0 logical :: has_selection = .false. class(expr_t), allocatable :: selection logical :: colorize_subevt = .false. contains <> end type subevt_expr_t @ %def subevt_expr_t @ Output: Base and extended version. We already have a [[write]] routine for the [[subevt_t]] parent type. <>= procedure :: base_write => subevt_expr_write <>= module subroutine subevt_expr_write (object, unit, pacified) class(subevt_expr_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacified end subroutine subevt_expr_write <>= module subroutine subevt_expr_write (object, unit, pacified) class(subevt_expr_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacified integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Local variables:" call write_separator (u) call object%var_list%write (u, follow_link=.false., & pacified = pacified) call write_separator (u) if (object%subevt_filled) then call object%subevt_t%write (u, pacified = pacified) if (object%has_selection) then call write_separator (u) write (u, "(1x,A)") "Selection expression:" call write_separator (u) call object%selection%write (u) end if else write (u, "(1x,A)") "subevt: [undefined]" end if end subroutine subevt_expr_write @ %def subevt_expr_write @ Finalizer. <>= procedure (subevt_expr_final), deferred :: final procedure :: base_final => subevt_expr_final <>= module subroutine subevt_expr_final (object) class(subevt_expr_t), intent(inout) :: object end subroutine subevt_expr_final <>= module subroutine subevt_expr_final (object) class(subevt_expr_t), intent(inout) :: object call object%var_list%final () if (object%has_selection) then call object%selection%final () end if end subroutine subevt_expr_final @ %def subevt_expr_final @ \subsection{Initialization} Initialization: define local variables and establish pointers. The common variables are [[sqrts]] (the nominal beam energy, fixed), [[sqrts_hat]] (the actual energy), [[n_in]], [[n_out]], and [[n_tot]] for the [[subevt]]. With the exception of [[sqrts]], all are implemented as pointers to subobjects. <>= procedure (subevt_expr_setup_vars), deferred :: setup_vars procedure :: base_setup_vars => subevt_expr_setup_vars <>= module subroutine subevt_expr_setup_vars (expr, sqrts) class(subevt_expr_t), intent(inout), target :: expr real(default), intent(in) :: sqrts end subroutine subevt_expr_setup_vars <>= module subroutine subevt_expr_setup_vars (expr, sqrts) class(subevt_expr_t), intent(inout), target :: expr real(default), intent(in) :: sqrts call expr%var_list%final () call expr%var_list%append_real (var_str ("sqrts"), sqrts, & locked = .true., verbose = .false., intrinsic = .true.) call expr%var_list%append_real_ptr (var_str ("sqrts_hat"), & expr%sqrts_hat, is_known = expr%subevt_filled, & locked = .true., verbose = .false., intrinsic = .true.) call expr%var_list%append_int_ptr (var_str ("n_in"), expr%n_in, & is_known = expr%subevt_filled, & locked = .true., verbose = .false., intrinsic = .true.) call expr%var_list%append_int_ptr (var_str ("n_out"), expr%n_out, & is_known = expr%subevt_filled, & locked = .true., verbose = .false., intrinsic = .true.) call expr%var_list%append_int_ptr (var_str ("n_tot"), expr%n_tot, & is_known = expr%subevt_filled, & locked = .true., verbose = .false., intrinsic = .true.) end subroutine subevt_expr_setup_vars @ %def subevt_expr_setup_vars @ Append the subevent expr (its base-type core) itself to the variable list, if it is not yet present. <>= procedure :: setup_var_self => subevt_expr_setup_var_self <>= module subroutine subevt_expr_setup_var_self (expr) class(subevt_expr_t), intent(inout), target :: expr end subroutine subevt_expr_setup_var_self <>= module subroutine subevt_expr_setup_var_self (expr) class(subevt_expr_t), intent(inout), target :: expr if (.not. expr%var_list%contains (var_str ("@evt"))) then call expr%var_list%append_subevt_ptr & (var_str ("@evt"), expr%subevt_t, & is_known = expr%subevt_filled, & locked = .true., verbose = .false., intrinsic=.true.) end if end subroutine subevt_expr_setup_var_self @ %def subevt_expr_setup_var_self @ Link a variable list to the local one. This could be done event by event, but before evaluating expressions. <>= procedure :: link_var_list => subevt_expr_link_var_list <>= module subroutine subevt_expr_link_var_list (expr, var_list) class(subevt_expr_t), intent(inout) :: expr type(var_list_t), intent(in), target :: var_list end subroutine subevt_expr_link_var_list <>= module subroutine subevt_expr_link_var_list (expr, var_list) class(subevt_expr_t), intent(inout) :: expr type(var_list_t), intent(in), target :: var_list call expr%var_list%link (var_list) end subroutine subevt_expr_link_var_list @ %def subevt_expr_link_var_list @ Compile the selection expression. If there is no expression, the build method will not allocate the expression object. <>= procedure :: setup_selection => subevt_expr_setup_selection <>= module subroutine subevt_expr_setup_selection (expr, ef_cuts) class(subevt_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_cuts end subroutine subevt_expr_setup_selection <>= module subroutine subevt_expr_setup_selection (expr, ef_cuts) class(subevt_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_cuts call ef_cuts%build (expr%selection) if (allocated (expr%selection)) then call expr%setup_var_self () call expr%selection%setup_lexpr (expr%var_list) expr%has_selection = .true. end if end subroutine subevt_expr_setup_selection @ %def subevt_expr_setup_selection @ (De)activate color storage and evaluation for the expression. The subevent particles will have color information. <>= procedure :: colorize => subevt_expr_colorize <>= module subroutine subevt_expr_colorize (expr, colorize_subevt) class(subevt_expr_t), intent(inout), target :: expr logical, intent(in) :: colorize_subevt end subroutine subevt_expr_colorize <>= module subroutine subevt_expr_colorize (expr, colorize_subevt) class(subevt_expr_t), intent(inout), target :: expr logical, intent(in) :: colorize_subevt expr%colorize_subevt = colorize_subevt end subroutine subevt_expr_colorize @ %def subevt_expr_colorize @ \subsection{Evaluation} Reset to initial state, i.e., mark the [[subevt]] as invalid. <>= procedure :: reset_contents => subevt_expr_reset_contents procedure :: base_reset_contents => subevt_expr_reset_contents <>= module subroutine subevt_expr_reset_contents (expr) class(subevt_expr_t), intent(inout) :: expr end subroutine subevt_expr_reset_contents <>= module subroutine subevt_expr_reset_contents (expr) class(subevt_expr_t), intent(inout) :: expr expr%subevt_filled = .false. end subroutine subevt_expr_reset_contents @ %def subevt_expr_reset_contents @ Evaluate the selection expression and return the result. There is also a deferred version: this should evaluate the remaining expressions if the event has passed. <>= procedure :: base_evaluate => subevt_expr_evaluate <>= module subroutine subevt_expr_evaluate (expr, passed) class(subevt_expr_t), intent(inout) :: expr logical, intent(out) :: passed end subroutine subevt_expr_evaluate <>= module subroutine subevt_expr_evaluate (expr, passed) class(subevt_expr_t), intent(inout) :: expr logical, intent(out) :: passed if (expr%has_selection) then call expr%selection%evaluate () if (expr%selection%is_known ()) then passed = expr%selection%get_log () else call msg_error ("Evaluate selection expression: result undefined") passed = .false. end if else passed = .true. end if end subroutine subevt_expr_evaluate @ %def subevt_expr_evaluate @ \subsection{Implementation for partonic events} This implementation contains the expressions that we can evaluate for the partonic process during integration. <>= public :: parton_expr_t <>= type, extends (subevt_expr_t) :: parton_expr_t integer, dimension(:), allocatable :: i_beam integer, dimension(:), allocatable :: i_in integer, dimension(:), allocatable :: i_out logical :: has_scale = .false. logical :: has_fac_scale = .false. logical :: has_ren_scale = .false. logical :: has_weight = .false. class(expr_t), allocatable :: scale class(expr_t), allocatable :: fac_scale class(expr_t), allocatable :: ren_scale class(expr_t), allocatable :: weight contains <> end type parton_expr_t @ %def parton_expr_t @ Finalizer. <>= procedure :: final => parton_expr_final <>= module subroutine parton_expr_final (object) class(parton_expr_t), intent(inout) :: object end subroutine parton_expr_final <>= module subroutine parton_expr_final (object) class(parton_expr_t), intent(inout) :: object call object%base_final () if (object%has_scale) then call object%scale%final () end if if (object%has_fac_scale) then call object%fac_scale%final () end if if (object%has_ren_scale) then call object%ren_scale%final () end if if (object%has_weight) then call object%weight%final () end if end subroutine parton_expr_final @ %def parton_expr_final @ Output: continue writing the active expressions, after the common selection expression. Note: the [[prefix]] argument is declared in the [[write]] method of the [[subevt_t]] base type. Here, it is unused. <>= procedure :: write => parton_expr_write <>= module subroutine parton_expr_write (object, unit, prefix, pacified) class(parton_expr_t), intent(in) :: object integer, intent(in), optional :: unit character(*), intent(in), optional :: prefix logical, intent(in), optional :: pacified end subroutine parton_expr_write <>= module subroutine parton_expr_write (object, unit, prefix, pacified) class(parton_expr_t), intent(in) :: object integer, intent(in), optional :: unit character(*), intent(in), optional :: prefix logical, intent(in), optional :: pacified integer :: u u = given_output_unit (unit) call object%base_write (u, pacified = pacified) if (object%subevt_filled) then if (object%has_scale) then call write_separator (u) write (u, "(1x,A)") "Scale expression:" call write_separator (u) call object%scale%write (u) end if if (object%has_fac_scale) then call write_separator (u) write (u, "(1x,A)") "Factorization scale expression:" call write_separator (u) call object%fac_scale%write (u) end if if (object%has_ren_scale) then call write_separator (u) write (u, "(1x,A)") "Renormalization scale expression:" call write_separator (u) call object%ren_scale%write (u) end if if (object%has_weight) then call write_separator (u) write (u, "(1x,A)") "Weight expression:" call write_separator (u) call object%weight%write (u) end if end if end subroutine parton_expr_write @ %def parton_expr_write @ Define variables. <>= procedure :: setup_vars => parton_expr_setup_vars <>= module subroutine parton_expr_setup_vars (expr, sqrts) class(parton_expr_t), intent(inout), target :: expr real(default), intent(in) :: sqrts end subroutine parton_expr_setup_vars <>= module subroutine parton_expr_setup_vars (expr, sqrts) class(parton_expr_t), intent(inout), target :: expr real(default), intent(in) :: sqrts call expr%base_setup_vars (sqrts) end subroutine parton_expr_setup_vars @ %def parton_expr_setup_vars @ Compile the scale expressions. If a pointer is disassociated, there is no expression. <>= procedure :: setup_scale => parton_expr_setup_scale procedure :: setup_fac_scale => parton_expr_setup_fac_scale procedure :: setup_ren_scale => parton_expr_setup_ren_scale <>= module subroutine parton_expr_setup_scale (expr, ef_scale) class(parton_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_scale end subroutine parton_expr_setup_scale module subroutine parton_expr_setup_fac_scale (expr, ef_fac_scale) class(parton_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_fac_scale end subroutine parton_expr_setup_fac_scale module subroutine parton_expr_setup_ren_scale (expr, ef_ren_scale) class(parton_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_ren_scale end subroutine parton_expr_setup_ren_scale <>= module subroutine parton_expr_setup_scale (expr, ef_scale) class(parton_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_scale call ef_scale%build (expr%scale) if (allocated (expr%scale)) then call expr%setup_var_self () call expr%scale%setup_expr (expr%var_list) expr%has_scale = .true. end if end subroutine parton_expr_setup_scale module subroutine parton_expr_setup_fac_scale (expr, ef_fac_scale) class(parton_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_fac_scale call ef_fac_scale%build (expr%fac_scale) if (allocated (expr%fac_scale)) then call expr%setup_var_self () call expr%fac_scale%setup_expr (expr%var_list) expr%has_fac_scale = .true. end if end subroutine parton_expr_setup_fac_scale module subroutine parton_expr_setup_ren_scale (expr, ef_ren_scale) class(parton_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_ren_scale call ef_ren_scale%build (expr%ren_scale) if (allocated (expr%ren_scale)) then call expr%setup_var_self () call expr%ren_scale%setup_expr (expr%var_list) expr%has_ren_scale = .true. end if end subroutine parton_expr_setup_ren_scale @ %def parton_expr_setup_scale @ %def parton_expr_setup_fac_scale @ %def parton_expr_setup_ren_scale @ Compile the weight expression. <>= procedure :: setup_weight => parton_expr_setup_weight <>= module subroutine parton_expr_setup_weight (expr, ef_weight) class(parton_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_weight end subroutine parton_expr_setup_weight <>= module subroutine parton_expr_setup_weight (expr, ef_weight) class(parton_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_weight call ef_weight%build (expr%weight) if (allocated (expr%weight)) then call expr%setup_var_self () call expr%weight%setup_expr (expr%var_list) expr%has_weight = .true. end if end subroutine parton_expr_setup_weight @ %def parton_expr_setup_weight @ Filling the partonic state consists of two parts. The first routine prepares the subevt without assigning momenta. It takes the particles from an [[interaction_t]]. It needs the indices and flavors for the beam, incoming, and outgoing particles. We can assume that the particle content of the subevt does not change. Therefore, we set the event variables [[n_in]], [[n_out]], [[n_tot]] already in this initialization step. <>= procedure :: setup_subevt => parton_expr_setup_subevt <>= module subroutine parton_expr_setup_subevt (expr, int, & i_beam, i_in, i_out, f_beam, f_in, f_out) class(parton_expr_t), intent(inout) :: expr type(interaction_t), intent(in), target :: int integer, dimension(:), intent(in) :: i_beam, i_in, i_out type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out end subroutine parton_expr_setup_subevt <>= module subroutine parton_expr_setup_subevt (expr, int, & i_beam, i_in, i_out, f_beam, f_in, f_out) class(parton_expr_t), intent(inout) :: expr type(interaction_t), intent(in), target :: int integer, dimension(:), intent(in) :: i_beam, i_in, i_out type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out allocate (expr%i_beam (size (i_beam))) allocate (expr%i_in (size (i_in))) allocate (expr%i_out (size (i_out))) expr%i_beam = i_beam expr%i_in = i_in expr%i_out = i_out call interaction_to_subevt (int, & expr%i_beam, expr%i_in, expr%i_out, expr%subevt_t) call expr%set_pdg_beam (f_beam%get_pdg ()) call expr%set_pdg_incoming (f_in%get_pdg ()) call expr%set_pdg_outgoing (f_out%get_pdg ()) call expr%set_p2_beam (f_beam%get_mass () ** 2) call expr%set_p2_incoming (f_in%get_mass () ** 2) call expr%set_p2_outgoing (f_out%get_mass () ** 2) expr%n_in = size (i_in) expr%n_out = size (i_out) expr%n_tot = expr%n_in + expr%n_out end subroutine parton_expr_setup_subevt @ %def parton_expr_setup_subevt <>= procedure :: renew_flv_content_subevt => parton_expr_renew_flv_content_subevt <>= module subroutine parton_expr_renew_flv_content_subevt (expr, int, & i_beam, i_in, i_out, f_beam, f_in, f_out) class(parton_expr_t), intent(inout) :: expr type(interaction_t), intent(in), target :: int integer, dimension(:), intent(in) :: i_beam, i_in, i_out type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out end subroutine parton_expr_renew_flv_content_subevt <>= module subroutine parton_expr_renew_flv_content_subevt (expr, int, & i_beam, i_in, i_out, f_beam, f_in, f_out) class(parton_expr_t), intent(inout) :: expr type(interaction_t), intent(in), target :: int integer, dimension(:), intent(in) :: i_beam, i_in, i_out type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out expr%i_beam = i_beam expr%i_in = i_in expr%i_out = i_out call expr%set_pdg_beam (f_beam%get_pdg ()) call expr%set_pdg_incoming (f_in%get_pdg ()) call expr%set_pdg_outgoing (f_out%get_pdg ()) expr%n_in = size (i_in) expr%n_out = size (i_out) expr%n_tot = expr%n_in + expr%n_out end subroutine parton_expr_renew_flv_content_subevt @ %def parton_expr_renew_flv_content_subevt @ Transfer PDG codes, masses (initalization) and momenta to a predefined subevent. We use the flavor assignment of the first branch in the interaction state matrix. Only incoming and outgoing particles are transferred. Switch momentum sign for incoming particles. <>= interface interaction_momenta_to_subevt module procedure interaction_momenta_to_subevt_id module procedure interaction_momenta_to_subevt_tr end interface <>= module subroutine interaction_momenta_to_subevt_id & (int, j_beam, j_in, j_out, subevt) type(interaction_t), intent(in) :: int integer, dimension(:), intent(in) :: j_beam, j_in, j_out type(subevt_t), intent(inout) :: subevt end subroutine interaction_momenta_to_subevt_id module subroutine interaction_momenta_to_subevt_tr & (int, j_beam, j_in, j_out, lt, subevt) type(interaction_t), intent(in) :: int integer, dimension(:), intent(in) :: j_beam, j_in, j_out type(subevt_t), intent(inout) :: subevt type(lorentz_transformation_t), intent(in) :: lt end subroutine interaction_momenta_to_subevt_tr <>= subroutine interaction_to_subevt (int, j_beam, j_in, j_out, subevt) type(interaction_t), intent(in), target :: int integer, dimension(:), intent(in) :: j_beam, j_in, j_out type(subevt_t), intent(out) :: subevt type(flavor_t), dimension(:), allocatable :: flv integer :: n_beam, n_in, n_out, i, j allocate (flv (int%get_n_tot ())) flv = quantum_numbers_get_flavor (int%get_quantum_numbers (1)) n_beam = size (j_beam) n_in = size (j_in) n_out = size (j_out) call subevt_init (subevt, n_beam + n_in + n_out) do i = 1, n_beam j = j_beam(i) call subevt%set_beam (i, flv(j)%get_pdg (), & vector4_null, flv(j)%get_mass () ** 2) end do do i = 1, n_in j = j_in(i) call subevt%set_incoming (n_beam + i, flv(j)%get_pdg (), & vector4_null, flv(j)%get_mass () ** 2) end do do i = 1, n_out j = j_out(i) call subevt%set_outgoing (n_beam + n_in + i, & flv(j)%get_pdg (), vector4_null, & flv(j)%get_mass () ** 2) end do end subroutine interaction_to_subevt module subroutine interaction_momenta_to_subevt_id & (int, j_beam, j_in, j_out, subevt) type(interaction_t), intent(in) :: int integer, dimension(:), intent(in) :: j_beam, j_in, j_out type(subevt_t), intent(inout) :: subevt call subevt%set_p_beam (- int%get_momenta (j_beam)) call subevt%set_p_incoming (- int%get_momenta (j_in)) call subevt%set_p_outgoing (int%get_momenta (j_out)) end subroutine interaction_momenta_to_subevt_id module subroutine interaction_momenta_to_subevt_tr & (int, j_beam, j_in, j_out, lt, subevt) type(interaction_t), intent(in) :: int integer, dimension(:), intent(in) :: j_beam, j_in, j_out type(subevt_t), intent(inout) :: subevt type(lorentz_transformation_t), intent(in) :: lt call subevt%set_p_beam (- lt * int%get_momenta (j_beam)) call subevt%set_p_incoming (- lt * int%get_momenta (j_in)) call subevt%set_p_outgoing (lt * int%get_momenta (j_out)) end subroutine interaction_momenta_to_subevt_tr @ %def interaction_momenta_to_subevt @ The second part takes the momenta from the interaction object and thus completes the subevt. The partonic energy can then be computed. <>= procedure :: fill_subevt => parton_expr_fill_subevt <>= module subroutine parton_expr_fill_subevt (expr, int) class(parton_expr_t), intent(inout) :: expr type(interaction_t), intent(in), target :: int end subroutine parton_expr_fill_subevt <>= module subroutine parton_expr_fill_subevt (expr, int) class(parton_expr_t), intent(inout) :: expr type(interaction_t), intent(in), target :: int call interaction_momenta_to_subevt (int, & expr%i_beam, expr%i_in, expr%i_out, expr%subevt_t) expr%sqrts_hat = expr%get_sqrts_hat () expr%subevt_filled = .true. end subroutine parton_expr_fill_subevt @ %def parton_expr_fill_subevt @ Evaluate, if the event passes the selection. For absent expressions we take default values. <>= procedure :: evaluate => parton_expr_evaluate <>= module subroutine parton_expr_evaluate (expr, passed, scale, fac_scale, & ren_scale, weight, scale_forced, force_evaluation) class(parton_expr_t), intent(inout) :: expr logical, intent(out) :: passed real(default), intent(out) :: scale real(default), allocatable, intent(out) :: fac_scale real(default), allocatable, intent(out) :: ren_scale real(default), intent(out) :: weight real(default), intent(in), allocatable, optional :: scale_forced logical, intent(in), optional :: force_evaluation end subroutine parton_expr_evaluate <>= module subroutine parton_expr_evaluate (expr, passed, scale, fac_scale, & ren_scale, weight, scale_forced, force_evaluation) class(parton_expr_t), intent(inout) :: expr logical, intent(out) :: passed real(default), intent(out) :: scale real(default), allocatable, intent(out) :: fac_scale real(default), allocatable, intent(out) :: ren_scale real(default), intent(out) :: weight real(default), intent(in), allocatable, optional :: scale_forced logical, intent(in), optional :: force_evaluation logical :: force_scale, force_eval force_scale = .false.; force_eval = .false. if (present (scale_forced)) force_scale = allocated (scale_forced) if (present (force_evaluation)) force_eval = force_evaluation call expr%base_evaluate (passed) if (passed .or. force_eval) then if (force_scale) then scale = scale_forced else if (expr%has_scale) then call expr%scale%evaluate () if (expr%scale%is_known ()) then scale = expr%scale%get_real () else call msg_error ("Evaluate scale expression: result undefined") scale = zero end if else scale = expr%sqrts_hat end if if (expr%has_fac_scale) then call expr%fac_scale%evaluate () if (expr%fac_scale%is_known ()) then if (.not. allocated (fac_scale)) then allocate (fac_scale, source = expr%fac_scale%get_real ()) else fac_scale = expr%fac_scale%get_real () end if else call msg_error ("Evaluate factorization scale expression: & &result undefined") end if end if if (expr%has_ren_scale) then call expr%ren_scale%evaluate () if (expr%ren_scale%is_known ()) then if (.not. allocated (ren_scale)) then allocate (ren_scale, source = expr%ren_scale%get_real ()) else ren_scale = expr%ren_scale%get_real () end if else call msg_error ("Evaluate renormalization scale expression: & &result undefined") end if end if if (expr%has_weight) then call expr%weight%evaluate () if (expr%weight%is_known ()) then weight = expr%weight%get_real () else call msg_error ("Evaluate weight expression: result undefined") weight = zero end if else weight = one end if else weight = zero end if end subroutine parton_expr_evaluate @ %def parton_expr_evaluate @ Return the beam/incoming parton indices. <>= procedure :: get_beam_index => parton_expr_get_beam_index procedure :: get_in_index => parton_expr_get_in_index <>= module subroutine parton_expr_get_beam_index (expr, i_beam) class(parton_expr_t), intent(in) :: expr integer, dimension(:), intent(out) :: i_beam end subroutine parton_expr_get_beam_index module subroutine parton_expr_get_in_index (expr, i_in) class(parton_expr_t), intent(in) :: expr integer, dimension(:), intent(out) :: i_in end subroutine parton_expr_get_in_index <>= module subroutine parton_expr_get_beam_index (expr, i_beam) class(parton_expr_t), intent(in) :: expr integer, dimension(:), intent(out) :: i_beam i_beam = expr%i_beam end subroutine parton_expr_get_beam_index module subroutine parton_expr_get_in_index (expr, i_in) class(parton_expr_t), intent(in) :: expr integer, dimension(:), intent(out) :: i_in i_in = expr%i_in end subroutine parton_expr_get_in_index @ %def parton_expr_get_beam_index @ %def parton_expr_get_in_index @ \subsection{Implementation for full events} This implementation contains the expressions that we can evaluate for the full event. It also contains data that pertain to the event, suitable for communication with external event formats. These data simultaneously serve as pointer targets for the variable lists hidden in the expressions (eval trees). Squared matrix element and weight values: when reading events from file, the [[ref]] value is the number in the file, while the [[prc]] value is the number that we calculate from the momenta in the file, possibly with different parameters. When generating events the first time, or if we do not recalculate, the numbers should coincide. Furthermore, the array of [[alt]] values is copied from an array of alternative event records. These values should represent calculated values. <>= public :: event_expr_t <>= type, extends (subevt_expr_t) :: event_expr_t logical :: has_reweight = .false. logical :: has_analysis = .false. class(expr_t), allocatable :: reweight class(expr_t), allocatable :: analysis logical :: has_id = .false. type(string_t) :: id logical :: has_num_id = .false. integer :: num_id = 0 logical :: has_index = .false. integer :: index = 0 logical :: has_sqme_ref = .false. real(default) :: sqme_ref = 0 logical :: has_sqme_prc = .false. real(default) :: sqme_prc = 0 logical :: has_weight_ref = .false. real(default) :: weight_ref = 0 logical :: has_weight_prc = .false. real(default) :: weight_prc = 0 logical :: has_excess_prc = .false. real(default) :: excess_prc = 0 integer :: n_alt = 0 logical :: has_sqme_alt = .false. real(default), dimension(:), allocatable :: sqme_alt logical :: has_weight_alt = .false. real(default), dimension(:), allocatable :: weight_alt contains <> end type event_expr_t @ %def event_expr_t @ Finalizer for the expressions. <>= procedure :: final => event_expr_final <>= module subroutine event_expr_final (object) class(event_expr_t), intent(inout) :: object end subroutine event_expr_final <>= module subroutine event_expr_final (object) class(event_expr_t), intent(inout) :: object call object%base_final () if (object%has_reweight) then call object%reweight%final () end if if (object%has_analysis) then call object%analysis%final () end if end subroutine event_expr_final @ %def event_expr_final @ Output: continue writing the active expressions, after the common selection expression. Note: the [[prefix]] argument is declared in the [[write]] method of the [[subevt_t]] base type. Here, it is unused. <>= procedure :: write => event_expr_write <>= module subroutine event_expr_write (object, unit, prefix, pacified) class(event_expr_t), intent(in) :: object integer, intent(in), optional :: unit character(*), intent(in), optional :: prefix logical, intent(in), optional :: pacified end subroutine event_expr_write <>= module subroutine event_expr_write (object, unit, prefix, pacified) class(event_expr_t), intent(in) :: object integer, intent(in), optional :: unit character(*), intent(in), optional :: prefix logical, intent(in), optional :: pacified integer :: u u = given_output_unit (unit) call object%base_write (u, pacified = pacified) if (object%subevt_filled) then if (object%has_reweight) then call write_separator (u) write (u, "(1x,A)") "Reweighting expression:" call write_separator (u) call object%reweight%write (u) end if if (object%has_analysis) then call write_separator (u) write (u, "(1x,A)") "Analysis expression:" call write_separator (u) call object%analysis%write (u) end if end if end subroutine event_expr_write @ %def event_expr_write @ Initializer. This is required only for the [[sqme_alt]] and [[weight_alt]] arrays. <>= procedure :: init => event_expr_init <>= module subroutine event_expr_init (expr, n_alt) class(event_expr_t), intent(out) :: expr integer, intent(in), optional :: n_alt end subroutine event_expr_init <>= module subroutine event_expr_init (expr, n_alt) class(event_expr_t), intent(out) :: expr integer, intent(in), optional :: n_alt if (present (n_alt)) then expr%n_alt = n_alt allocate (expr%sqme_alt (n_alt), source = 0._default) allocate (expr%weight_alt (n_alt), source = 0._default) end if end subroutine event_expr_init @ %def event_expr_init @ Define variables. We have the variables of the base type plus specific variables for full events. There is the event index. <>= procedure :: setup_vars => event_expr_setup_vars <>= module subroutine event_expr_setup_vars (expr, sqrts) class(event_expr_t), intent(inout), target :: expr real(default), intent(in) :: sqrts end subroutine event_expr_setup_vars <>= module subroutine event_expr_setup_vars (expr, sqrts) class(event_expr_t), intent(inout), target :: expr real(default), intent(in) :: sqrts call expr%base_setup_vars (sqrts) call expr%var_list%append_string_ptr (var_str ("$process_id"), & expr%id, is_known = expr%has_id, & locked = .true., verbose = .false., intrinsic = .true.) call expr%var_list%append_int_ptr (var_str ("process_num_id"), & expr%num_id, is_known = expr%has_num_id, & locked = .true., verbose = .false., intrinsic = .true.) call expr%var_list%append_real_ptr (var_str ("sqme"), & expr%sqme_prc, is_known = expr%has_sqme_prc, & locked = .true., verbose = .false., intrinsic = .true.) call expr%var_list%append_real_ptr (var_str ("sqme_ref"), & expr%sqme_ref, is_known = expr%has_sqme_ref, & locked = .true., verbose = .false., intrinsic = .true.) call expr%var_list%append_int_ptr (var_str ("event_index"), & expr%index, is_known = expr%has_index, & locked = .true., verbose = .false., intrinsic = .true.) call expr%var_list%append_real_ptr (var_str ("event_weight"), & expr%weight_prc, is_known = expr%has_weight_prc, & locked = .true., verbose = .false., intrinsic = .true.) call expr%var_list%append_real_ptr (var_str ("event_weight_ref"), & expr%weight_ref, is_known = expr%has_weight_ref, & locked = .true., verbose = .false., intrinsic = .true.) call expr%var_list%append_real_ptr (var_str ("event_excess"), & expr%excess_prc, is_known = expr%has_excess_prc, & locked = .true., verbose = .false., intrinsic = .true.) end subroutine event_expr_setup_vars @ %def event_expr_setup_vars @ Compile the analysis expression. If the pointer is disassociated, there is no expression. <>= procedure :: setup_analysis => event_expr_setup_analysis <>= module subroutine event_expr_setup_analysis (expr, ef_analysis) class(event_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_analysis end subroutine event_expr_setup_analysis <>= module subroutine event_expr_setup_analysis (expr, ef_analysis) class(event_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_analysis call ef_analysis%build (expr%analysis) if (allocated (expr%analysis)) then call expr%setup_var_self () call expr%analysis%setup_lexpr (expr%var_list) expr%has_analysis = .true. end if end subroutine event_expr_setup_analysis @ %def event_expr_setup_analysis @ Compile the reweight expression. <>= procedure :: setup_reweight => event_expr_setup_reweight <>= module subroutine event_expr_setup_reweight (expr, ef_reweight) class(event_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_reweight end subroutine event_expr_setup_reweight <>= module subroutine event_expr_setup_reweight (expr, ef_reweight) class(event_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_reweight call ef_reweight%build (expr%reweight) if (allocated (expr%reweight)) then call expr%setup_var_self () call expr%reweight%setup_expr (expr%var_list) expr%has_reweight = .true. end if end subroutine event_expr_setup_reweight @ %def event_expr_setup_reweight @ Store the string or numeric process ID. This should be done during initialization. <>= procedure :: set_process_id => event_expr_set_process_id procedure :: set_process_num_id => event_expr_set_process_num_id <>= module subroutine event_expr_set_process_id (expr, id) class(event_expr_t), intent(inout) :: expr type(string_t), intent(in) :: id end subroutine event_expr_set_process_id module subroutine event_expr_set_process_num_id (expr, num_id) class(event_expr_t), intent(inout) :: expr integer, intent(in) :: num_id end subroutine event_expr_set_process_num_id <>= module subroutine event_expr_set_process_id (expr, id) class(event_expr_t), intent(inout) :: expr type(string_t), intent(in) :: id expr%id = id expr%has_id = .true. end subroutine event_expr_set_process_id module subroutine event_expr_set_process_num_id (expr, num_id) class(event_expr_t), intent(inout) :: expr integer, intent(in) :: num_id expr%num_id = num_id expr%has_num_id = .true. end subroutine event_expr_set_process_num_id @ %def event_expr_set_process_id @ %def event_expr_set_process_num_id @ Reset / set the data that pertain to a particular event. The event index is reset unless explicitly told to keep it. <>= procedure :: reset_contents => event_expr_reset_contents procedure :: set => event_expr_set <>= module subroutine event_expr_reset_contents (expr) class(event_expr_t), intent(inout) :: expr end subroutine event_expr_reset_contents module subroutine event_expr_set (expr, & weight_ref, weight_prc, weight_alt, & excess_prc, & sqme_ref, sqme_prc, sqme_alt) class(event_expr_t), intent(inout) :: expr real(default), intent(in), optional :: weight_ref, weight_prc real(default), intent(in), optional :: excess_prc real(default), intent(in), optional :: sqme_ref, sqme_prc real(default), dimension(:), intent(in), optional :: sqme_alt, weight_alt end subroutine event_expr_set <>= module subroutine event_expr_reset_contents (expr) class(event_expr_t), intent(inout) :: expr call expr%base_reset_contents () expr%has_sqme_ref = .false. expr%has_sqme_prc = .false. expr%has_sqme_alt = .false. expr%has_weight_ref = .false. expr%has_weight_prc = .false. expr%has_weight_alt = .false. expr%has_excess_prc = .false. end subroutine event_expr_reset_contents module subroutine event_expr_set (expr, & weight_ref, weight_prc, weight_alt, & excess_prc, & sqme_ref, sqme_prc, sqme_alt) class(event_expr_t), intent(inout) :: expr real(default), intent(in), optional :: weight_ref, weight_prc real(default), intent(in), optional :: excess_prc real(default), intent(in), optional :: sqme_ref, sqme_prc real(default), dimension(:), intent(in), optional :: sqme_alt, weight_alt if (present (sqme_ref)) then expr%has_sqme_ref = .true. expr%sqme_ref = sqme_ref end if if (present (sqme_prc)) then expr%has_sqme_prc = .true. expr%sqme_prc = sqme_prc end if if (present (sqme_alt)) then expr%has_sqme_alt = .true. expr%sqme_alt = sqme_alt end if if (present (weight_ref)) then expr%has_weight_ref = .true. expr%weight_ref = weight_ref end if if (present (weight_prc)) then expr%has_weight_prc = .true. expr%weight_prc = weight_prc end if if (present (weight_alt)) then expr%has_weight_alt = .true. expr%weight_alt = weight_alt end if if (present (excess_prc)) then expr%has_excess_prc = .true. expr%excess_prc = excess_prc end if end subroutine event_expr_set @ %def event_expr_reset_contents event_expr_set @ Access the subevent index. <>= procedure :: has_event_index => event_expr_has_event_index procedure :: get_event_index => event_expr_get_event_index <>= module function event_expr_has_event_index (expr) result (flag) class(event_expr_t), intent(in) :: expr logical :: flag end function event_expr_has_event_index module function event_expr_get_event_index (expr) result (index) class(event_expr_t), intent(in) :: expr integer :: index end function event_expr_get_event_index <>= module function event_expr_has_event_index (expr) result (flag) class(event_expr_t), intent(in) :: expr logical :: flag flag = expr%has_index end function event_expr_has_event_index module function event_expr_get_event_index (expr) result (index) class(event_expr_t), intent(in) :: expr integer :: index if (expr%has_index) then index = expr%index else index = 0 end if end function event_expr_get_event_index @ %def event_expr_has_event_index @ %def event_expr_get_event_index @ Set/increment the subevent index. Initialize it if necessary. <>= procedure :: set_event_index => event_expr_set_event_index procedure :: reset_event_index => event_expr_reset_event_index procedure :: increment_event_index => event_expr_increment_event_index <>= module subroutine event_expr_set_event_index (expr, index) class(event_expr_t), intent(inout) :: expr integer, intent(in) :: index end subroutine event_expr_set_event_index module subroutine event_expr_reset_event_index (expr) class(event_expr_t), intent(inout) :: expr end subroutine event_expr_reset_event_index module subroutine event_expr_increment_event_index (expr, offset) class(event_expr_t), intent(inout) :: expr integer, intent(in), optional :: offset end subroutine event_expr_increment_event_index <>= module subroutine event_expr_set_event_index (expr, index) class(event_expr_t), intent(inout) :: expr integer, intent(in) :: index expr%index = index expr%has_index = .true. end subroutine event_expr_set_event_index module subroutine event_expr_reset_event_index (expr) class(event_expr_t), intent(inout) :: expr expr%has_index = .false. end subroutine event_expr_reset_event_index module subroutine event_expr_increment_event_index (expr, offset) class(event_expr_t), intent(inout) :: expr integer, intent(in), optional :: offset if (expr%has_index) then expr%index = expr%index + 1 else if (present (offset)) then call expr%set_event_index (offset + 1) else call expr%set_event_index (1) end if end subroutine event_expr_increment_event_index @ %def event_expr_set_event_index @ %def event_expr_increment_event_index @ Fill the event expression: take the particle data and kinematics from a [[particle_set]] object. We allow the particle content to change for each event. Therefore, we set the event variables each time. Also increment the event index; initialize it if necessary. <>= procedure :: fill_subevt => event_expr_fill_subevt <>= module subroutine event_expr_fill_subevt (expr, particle_set) class(event_expr_t), intent(inout) :: expr type(particle_set_t), intent(in) :: particle_set end subroutine event_expr_fill_subevt <>= module subroutine event_expr_fill_subevt (expr, particle_set) class(event_expr_t), intent(inout) :: expr type(particle_set_t), intent(in) :: particle_set call particle_set%to_subevt (expr%subevt_t, expr%colorize_subevt) expr%sqrts_hat = expr%get_sqrts_hat () expr%n_in = expr%get_n_in () expr%n_out = expr%get_n_out () expr%n_tot = expr%n_in + expr%n_out expr%subevt_filled = .true. end subroutine event_expr_fill_subevt @ %def event_expr_fill_subevt @ Evaluate, if the event passes the selection. For absent expressions we take default values. <>= procedure :: evaluate => event_expr_evaluate <>= module subroutine event_expr_evaluate & (expr, passed, reweight, analysis_flag) class(event_expr_t), intent(inout) :: expr logical, intent(out) :: passed real(default), intent(out) :: reweight logical, intent(out) :: analysis_flag end subroutine event_expr_evaluate <>= module subroutine event_expr_evaluate (expr, passed, reweight, analysis_flag) class(event_expr_t), intent(inout) :: expr logical, intent(out) :: passed real(default), intent(out) :: reweight logical, intent(out) :: analysis_flag call expr%base_evaluate (passed) if (passed) then if (expr%has_reweight) then call expr%reweight%evaluate () if (expr%reweight%is_known ()) then reweight = expr%reweight%get_real () else call msg_error ("Evaluate reweight expression: & &result undefined") reweight = 0 end if else reweight = 1 end if if (expr%has_analysis) then call expr%analysis%evaluate () if (expr%analysis%is_known ()) then analysis_flag = expr%analysis%get_log () else call msg_error ("Evaluate analysis expression: & &result undefined") analysis_flag = .false. end if else analysis_flag = .true. end if end if end subroutine event_expr_evaluate @ %def event_expr_evaluate @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Parton states} A [[parton_state_t]] object contains the effective kinematics and dynamics of an elementary partonic interaction, with or without the beam/structure function state included. The type is abstract and has two distinct extensions. The [[isolated_state_t]] extension describes the isolated elementary interaction where the [[int_eff]] subobject contains the complex transition amplitude, exclusive in all quantum numbers. The particle content and kinematics describe the effective partonic state. The [[connected_state_t]] extension contains the partonic [[subevt]] and the expressions for cuts and scales which use it. In the isolated state, the effective partonic interaction may either be identical to the hard interaction, in which case it is just a pointer to the latter. Or it may involve a rearrangement of partons, in which case we allocate it explicitly and flag this by [[int_is_allocated]]. The [[trace]] evaluator contains the absolute square of the effective transition amplitude matrix, summed over final states. It is also summed over initial states, depending on the the beam setup allows. The result is used for integration. The [[matrix]] evaluator is the counterpart of [[trace]] which is kept exclusive in all observable quantum numbers. The [[flows]] evaluator is furthermore exclusive in colors, but neglecting all color interference. The [[matrix]] and [[flows]] evaluators are filled only for sampling points that become part of physical events. Note: It would be natural to make the evaluators allocatable. The extra [[has_XXX]] flags indicate whether evaluators are active, instead. This module contains no unit tests. The tests are covered by the [[processes]] module below. <<[[parton_states.f90]]>>= <> module parton_states <> use variables use expr_base use model_data use flavors use quantum_numbers use state_matrices use interactions use evaluators use beams use sf_base use prc_core use subevt_expr <> <> <> interface <> end interface end module parton_states @ %def parton_states @ <<[[parton_states_sub.f90]]>>= <> submodule (parton_states) parton_states_s <> use io_units use format_utils, only: write_separator use diagnostics use lorentz use subevents use helicities use colors use polarizations use process_constants implicit none contains <> end submodule parton_states_s @ %def parton_states_s @ \subsection{Abstract base type} The common part are the evaluators, one for the trace (summed over all quantum numbers), one for the transition matrix (summed only over unobservable quantum numbers), and one for the flow distribution (transition matrix without interferences, exclusive in color flow). <>= type, abstract :: parton_state_t logical :: has_trace = .false. logical :: has_matrix = .false. logical :: has_flows = .false. type(evaluator_t) :: trace type(evaluator_t) :: matrix type(evaluator_t) :: flows contains <> end type parton_state_t @ %def parton_state_t @ The [[isolated_state_t]] extension contains the [[sf_chain_eff]] object and the (hard) effective interaction [[int_eff]], separately, both are implemented as a pointer. The evaluators (trace, matrix, flows) apply to the hard interaction only. If the effective interaction differs from the hard interaction, the pointer is allocated explicitly. Analogously for [[sf_chain_eff]]. <>= public :: isolated_state_t <>= type, extends (parton_state_t) :: isolated_state_t logical :: sf_chain_is_allocated = .false. type(sf_chain_instance_t), pointer :: sf_chain_eff => null () logical :: int_is_allocated = .false. type(interaction_t), pointer :: int_eff => null () contains <> end type isolated_state_t @ %def isolated_state_t @ The [[connected_state_t]] extension contains all data that enable the evaluation of observables for the effective connected state. The evaluators connect the (effective) structure-function chain and hard interaction that were kept separate in the [[isolated_state_t]]. The [[flows_sf]] evaluator is an extended copy of the structure-function The [[expr]] subobject consists of the [[subevt]], a simple event record, expressions for cuts etc.\ which refer to this record, and a [[var_list]] which contains event-specific variables, linked to the process variable list. Variables used within the expressions are looked up in [[var_list]]. <>= public :: connected_state_t <>= type, extends (parton_state_t) :: connected_state_t type(state_flv_content_t) :: state_flv logical :: has_flows_sf = .false. type(evaluator_t) :: flows_sf logical :: has_expr = .false. type(parton_expr_t) :: expr contains <> end type connected_state_t @ %def connected_state_t @ Output: each evaluator is written only when it is active. The [[sf_chain]] is only written if it is explicitly allocated. <>= procedure :: write => parton_state_write <>= module subroutine parton_state_write (state, unit, testflag) class(parton_state_t), intent(in) :: state integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine parton_state_write <>= module subroutine parton_state_write (state, unit, testflag) class(parton_state_t), intent(in) :: state integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) select type (state) class is (isolated_state_t) if (state%sf_chain_is_allocated) then call write_separator (u) call state%sf_chain_eff%write (u) end if if (state%int_is_allocated) then call write_separator (u) write (u, "(1x,A)") & "Effective interaction:" call write_separator (u) call state%int_eff%basic_write (u, testflag = testflag) end if class is (connected_state_t) if (state%has_flows_sf) then call write_separator (u) write (u, "(1x,A)") & "Evaluator (extension of the beam evaluator & &with color contractions):" call write_separator (u) call state%flows_sf%write (u, testflag = testflag) end if end select if (state%has_trace) then call write_separator (u) write (u, "(1x,A)") & "Evaluator (trace of the squared transition matrix):" call write_separator (u) call state%trace%write (u, testflag = testflag) end if if (state%has_matrix) then call write_separator (u) write (u, "(1x,A)") & "Evaluator (squared transition matrix):" call write_separator (u) call state%matrix%write (u, testflag = testflag) end if if (state%has_flows) then call write_separator (u) write (u, "(1x,A)") & "Evaluator (squared color-flow matrix):" call write_separator (u) call state%flows%write (u, testflag = testflag) end if select type (state) class is (connected_state_t) if (state%has_expr) then call write_separator (u) call state%expr%write (u) end if end select end subroutine parton_state_write @ %def parton_state_write @ Finalize interaction and evaluators, but only if allocated. <>= procedure :: final => parton_state_final <>= module subroutine parton_state_final (state) class(parton_state_t), intent(inout) :: state end subroutine parton_state_final <>= module subroutine parton_state_final (state) class(parton_state_t), intent(inout) :: state if (state%has_flows) then call state%flows%final () state%has_flows = .false. end if if (state%has_matrix) then call state%matrix%final () state%has_matrix = .false. end if if (state%has_trace) then call state%trace%final () state%has_trace = .false. end if select type (state) class is (connected_state_t) if (state%has_flows_sf) then call state%flows_sf%final () state%has_flows_sf = .false. end if call state%expr%final () class is (isolated_state_t) if (state%int_is_allocated) then call state%int_eff%final () deallocate (state%int_eff) state%int_is_allocated = .false. end if if (state%sf_chain_is_allocated) then call state%sf_chain_eff%final () end if end select end subroutine parton_state_final @ %def parton_state_final @ \subsection{Common Initialization} Initialize the isolated parton state. In this version, the effective structure-function chain [[sf_chain_eff]] and the effective interaction [[int_eff]] both are trivial pointers to the seed structure-function chain and to the hard interaction, respectively. <>= procedure :: init => isolated_state_init <>= module subroutine isolated_state_init (state, sf_chain, int) class(isolated_state_t), intent(out) :: state type(sf_chain_instance_t), intent(in), target :: sf_chain type(interaction_t), intent(in), target :: int end subroutine isolated_state_init <>= module subroutine isolated_state_init (state, sf_chain, int) class(isolated_state_t), intent(out) :: state type(sf_chain_instance_t), intent(in), target :: sf_chain type(interaction_t), intent(in), target :: int state%sf_chain_eff => sf_chain state%int_eff => int end subroutine isolated_state_init @ %def isolated_state_init @ \subsection{Evaluator initialization: isolated state} Create an evaluator for the trace of the squared transition matrix. The trace goes over all outgoing quantum numbers. Whether we trace over incoming quantum numbers other than color, depends on the given [[qn_mask_in]]. There are two options: explicitly computing the color factor table ([[use_cf]] false; [[nc]] defined), or taking the color factor table from the hard matrix element data. <>= procedure :: setup_square_trace => isolated_state_setup_square_trace <>= module subroutine isolated_state_setup_square_trace (state, core, & qn_mask_in, col, keep_fs_flavor) class(isolated_state_t), intent(inout), target :: state class(prc_core_t), intent(in) :: core type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask_in integer, intent(in), dimension(:), allocatable :: col logical, intent(in) :: keep_fs_flavor end subroutine isolated_state_setup_square_trace <>= module subroutine isolated_state_setup_square_trace (state, core, & qn_mask_in, col, keep_fs_flavor) class(isolated_state_t), intent(inout), target :: state class(prc_core_t), intent(in) :: core type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask_in !!! Actually need allocatable attribute here for once because col might !!! enter the subroutine non-allocated. integer, intent(in), dimension(:), allocatable :: col logical, intent(in) :: keep_fs_flavor type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask associate (data => core%data) allocate (qn_mask (data%n_in + data%n_out)) qn_mask( : data%n_in) = & quantum_numbers_mask (.false., .true., .false.) & .or. qn_mask_in qn_mask(data%n_in + 1 : ) = & quantum_numbers_mask (.not. keep_fs_flavor, .true., .true.) if (core%use_color_factors) then call state%trace%init_square (state%int_eff, qn_mask, & col_flow_index = data%cf_index, & col_factor = data%color_factors, & col_index_hi = col, & nc = core%nc) else call state%trace%init_square (state%int_eff, qn_mask, nc = core%nc) end if end associate state%has_trace = .true. end subroutine isolated_state_setup_square_trace @ %def isolated_state_setup_square_trace @ Set up an identity-evaluator for the trace. This implies that [[me]] is considered to be a squared amplitude, as for example for BLHA matrix elements. <>= procedure :: setup_identity_trace => isolated_state_setup_identity_trace <>= module subroutine isolated_state_setup_identity_trace (state, core, & qn_mask_in, keep_fs_flavors, keep_colors) class(isolated_state_t), intent(inout), target :: state class(prc_core_t), intent(in) :: core type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask_in logical, intent(in), optional :: keep_fs_flavors, keep_colors end subroutine isolated_state_setup_identity_trace <>= module subroutine isolated_state_setup_identity_trace (state, core, & qn_mask_in, keep_fs_flavors, keep_colors) class(isolated_state_t), intent(inout), target :: state class(prc_core_t), intent(in) :: core type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask_in logical, intent(in), optional :: keep_fs_flavors, keep_colors type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask logical :: fs_flv_flag, col_flag fs_flv_flag = .true.; col_flag = .true. if (present(keep_fs_flavors)) fs_flv_flag = .not. keep_fs_flavors if (present(keep_colors)) col_flag = .not. keep_colors associate (data => core%data) allocate (qn_mask (data%n_in + data%n_out)) qn_mask( : data%n_in) = & quantum_numbers_mask (.false., col_flag, .false.) .or. qn_mask_in qn_mask(data%n_in + 1 : ) = & quantum_numbers_mask (fs_flv_flag, col_flag, .true.) end associate call state%int_eff%set_mask (qn_mask) call state%trace%init_identity (state%int_eff) state%has_trace = .true. end subroutine isolated_state_setup_identity_trace @ %def isolated_state_setup_identity_trace @ Set up the evaluator for the transition matrix, exclusive in helicities where this is requested. For all unstable final-state particles we keep polarization according to the applicable decay options. If the process is a decay itself, this applies also to the initial state. For all polarized final-state particles, we keep polarization including off-diagonal entries. We drop helicity completely for unpolarized final-state particles. For the initial state, if the particle has not been handled yet, we apply the provided [[qn_mask_in]] which communicates the beam properties. <>= procedure :: setup_square_matrix => isolated_state_setup_square_matrix <>= module subroutine isolated_state_setup_square_matrix & (state, core, model, qn_mask_in, col) class(isolated_state_t), intent(inout), target :: state class(prc_core_t), intent(in) :: core class(model_data_t), intent(in), target :: model type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in integer, dimension(:), intent(in) :: col end subroutine isolated_state_setup_square_matrix <>= module subroutine isolated_state_setup_square_matrix & (state, core, model, qn_mask_in, col) class(isolated_state_t), intent(inout), target :: state class(prc_core_t), intent(in) :: core class(model_data_t), intent(in), target :: model type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in integer, dimension(:), intent(in) :: col type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask type(flavor_t), dimension(:), allocatable :: flv integer :: i logical :: helmask, helmask_hd associate (data => core%data) allocate (qn_mask (data%n_in + data%n_out)) allocate (flv (data%n_flv)) do i = 1, data%n_in + data%n_out call flv%init (data%flv_state(i,:), model) if ((data%n_in == 1 .or. i > data%n_in) & .and. any (.not. flv%is_stable ())) then helmask = all (flv%decays_isotropically ()) helmask_hd = all (flv%decays_diagonal ()) qn_mask(i) = quantum_numbers_mask (.false., .true., helmask, & mask_hd = helmask_hd) else if (i > data%n_in) then helmask = all (.not. flv%is_polarized ()) qn_mask(i) = quantum_numbers_mask (.false., .true., helmask) else qn_mask(i) = quantum_numbers_mask (.false., .true., .false.) & .or. qn_mask_in(i) end if end do if (core%use_color_factors) then call state%matrix%init_square (state%int_eff, qn_mask, & col_flow_index = data%cf_index, & col_factor = data%color_factors, & col_index_hi = col, & nc = core%nc) else call state%matrix%init_square (state%int_eff, & qn_mask, & nc = core%nc) end if end associate state%has_matrix = .true. end subroutine isolated_state_setup_square_matrix @ %def isolated_state_setup_square_matrix @ This procedure initializes the evaluator that computes the contributions to color flows, neglecting color interference. The incoming-particle mask can be used to sum over incoming flavor. Helicity handling: see above. <>= procedure :: setup_square_flows => isolated_state_setup_square_flows <>= module subroutine isolated_state_setup_square_flows & (state, core, model, qn_mask_in) class(isolated_state_t), intent(inout), target :: state class(prc_core_t), intent(in) :: core class(model_data_t), intent(in), target :: model type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in end subroutine isolated_state_setup_square_flows <>= module subroutine isolated_state_setup_square_flows & (state, core, model, qn_mask_in) class(isolated_state_t), intent(inout), target :: state class(prc_core_t), intent(in) :: core class(model_data_t), intent(in), target :: model type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask type(flavor_t), dimension(:), allocatable :: flv integer :: i logical :: helmask, helmask_hd associate (data => core%data) allocate (qn_mask (data%n_in + data%n_out)) allocate (flv (data%n_flv)) do i = 1, data%n_in + data%n_out call flv%init (data%flv_state(i,:), model) if ((data%n_in == 1 .or. i > data%n_in) & .and. any (.not. flv%is_stable ())) then helmask = all (flv%decays_isotropically ()) helmask_hd = all (flv%decays_diagonal ()) qn_mask(i) = quantum_numbers_mask (.false., .false., helmask, & mask_hd = helmask_hd) else if (i > data%n_in) then helmask = all (.not. flv%is_polarized ()) qn_mask(i) = quantum_numbers_mask (.false., .false., helmask) else qn_mask(i) = quantum_numbers_mask (.false., .false., .false.) & .or. qn_mask_in(i) end if end do call state%flows%init_square (state%int_eff, qn_mask, & expand_color_flows = .true.) end associate state%has_flows = .true. end subroutine isolated_state_setup_square_flows @ %def isolated_state_setup_square_flows @ \subsection{Evaluator initialization: connected state} Set up a trace evaluator as a product of two evaluators (incoming state, effective interaction). In the result, all quantum numbers are summed over. If the optional [[int]] interaction is provided, use this for the first factor in the convolution. Otherwise, use the final interaction of the stored [[sf_chain]]. The [[resonant]] flag applies if we want to construct a decay chain. The resonance property can propagate to the final event output. If an extended structure function is required [[requires_extended_sf]], we have to not consider [[sub]] as a quantum number. <>= procedure :: setup_connected_trace => connected_state_setup_connected_trace <>= module subroutine connected_state_setup_connected_trace & (state, isolated, int, resonant, undo_helicities, & keep_fs_flavors, requires_extended_sf) class(connected_state_t), intent(inout), target :: state type(isolated_state_t), intent(in), target :: isolated type(interaction_t), intent(in), optional, target :: int logical, intent(in), optional :: resonant logical, intent(in), optional :: undo_helicities logical, intent(in), optional :: keep_fs_flavors logical, intent(in), optional :: requires_extended_sf end subroutine connected_state_setup_connected_trace <>= module subroutine connected_state_setup_connected_trace & (state, isolated, int, resonant, undo_helicities, & keep_fs_flavors, requires_extended_sf) class(connected_state_t), intent(inout), target :: state type(isolated_state_t), intent(in), target :: isolated type(interaction_t), intent(in), optional, target :: int logical, intent(in), optional :: resonant logical, intent(in), optional :: undo_helicities logical, intent(in), optional :: keep_fs_flavors logical, intent(in), optional :: requires_extended_sf type(quantum_numbers_mask_t) :: mask type(interaction_t), pointer :: src_int, beam_int logical :: reduce, fs_flv_flag if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, & "connected_state_setup_connected_trace") reduce = .false.; fs_flv_flag = .true. if (present (undo_helicities)) reduce = undo_helicities if (present (keep_fs_flavors)) fs_flv_flag = .not. keep_fs_flavors mask = quantum_numbers_mask (fs_flv_flag, .true., .true.) if (present (int)) then src_int => int else src_int => isolated%sf_chain_eff%get_out_int_ptr () end if if (debug2_active (D_PROCESS_INTEGRATION)) then call src_int%basic_write () end if call state%trace%init_product (src_int, isolated%trace, & qn_mask_conn = mask, & qn_mask_rest = mask, & connections_are_resonant = resonant, & ignore_sub_for_qn = requires_extended_sf) if (reduce) then beam_int => isolated%sf_chain_eff%get_beam_int_ptr () call undo_qn_hel (beam_int, mask, beam_int%get_n_tot ()) call undo_qn_hel (src_int, mask, src_int%get_n_tot ()) call beam_int%set_matrix_element (cmplx (1, 0, default)) call src_int%set_matrix_element (cmplx (1, 0, default)) end if state%has_trace = .true. contains subroutine undo_qn_hel (int_in, mask, n_tot) type(interaction_t), intent(inout) :: int_in type(quantum_numbers_mask_t), intent(in) :: mask integer, intent(in) :: n_tot type(quantum_numbers_mask_t), dimension(n_tot) :: mask_in mask_in = mask call int_in%set_mask (mask_in) end subroutine undo_qn_hel end subroutine connected_state_setup_connected_trace @ %def connected_state_setup_connected_trace @ Set up a matrix evaluator as a product of two evaluators (incoming state, effective interation). In the intermediate state, color and helicity is summed over. In the final state, we keep the quantum numbers which are present in the original evaluators. <>= procedure :: setup_connected_matrix => connected_state_setup_connected_matrix <>= module subroutine connected_state_setup_connected_matrix & (state, isolated, int, resonant, qn_filter_conn) class(connected_state_t), intent(inout), target :: state type(isolated_state_t), intent(in), target :: isolated type(interaction_t), intent(in), optional, target :: int logical, intent(in), optional :: resonant type(quantum_numbers_t), intent(in), optional :: qn_filter_conn end subroutine connected_state_setup_connected_matrix <>= module subroutine connected_state_setup_connected_matrix & (state, isolated, int, resonant, qn_filter_conn) class(connected_state_t), intent(inout), target :: state type(isolated_state_t), intent(in), target :: isolated type(interaction_t), intent(in), optional, target :: int logical, intent(in), optional :: resonant type(quantum_numbers_t), intent(in), optional :: qn_filter_conn type(quantum_numbers_mask_t) :: mask type(interaction_t), pointer :: src_int mask = quantum_numbers_mask (.false., .true., .true.) if (present (int)) then src_int => int else src_int => isolated%sf_chain_eff%get_out_int_ptr () end if call state%matrix%init_product & (src_int, isolated%matrix, mask, & qn_filter_conn = qn_filter_conn, & connections_are_resonant = resonant) state%has_matrix = .true. end subroutine connected_state_setup_connected_matrix @ %def connected_state_setup_connected_matrix @ Set up a matrix evaluator as a product of two evaluators (incoming state, effective interation). In the intermediate state, only helicity is summed over. In the final state, we keep the quantum numbers which are present in the original evaluators. If the optional [[int]] interaction is provided, use this for the first factor in the convolution. Otherwise, use the final interaction of the stored [[sf_chain]], after creating an intermediate interaction that includes a correlated color state. We assume that for a caller-provided [[int]], this is not necessary. For fixed-order NLO differential distribution, we are interested at the partonic level, no parton showering takes place as this would demand for a proper matching. So, the flows in the [[connected_state]] are not needed, and the color part will be masked for the interaction coming from the [[sf_chain]]. The squared matrix elements coming from the OLP provider at the moment do not come with flows anyhow. This needs to be revised once the matching to the shower is completed. <>= procedure :: setup_connected_flows => connected_state_setup_connected_flows <>= module subroutine connected_state_setup_connected_flows & (state, isolated, int, resonant, qn_filter_conn, mask_color) class(connected_state_t), intent(inout), target :: state type(isolated_state_t), intent(in), target :: isolated type(interaction_t), intent(in), optional, target :: int logical, intent(in), optional :: resonant, mask_color type(quantum_numbers_t), intent(in), optional :: qn_filter_conn end subroutine connected_state_setup_connected_flows <>= module subroutine connected_state_setup_connected_flows & (state, isolated, int, resonant, qn_filter_conn, mask_color) class(connected_state_t), intent(inout), target :: state type(isolated_state_t), intent(in), target :: isolated type(interaction_t), intent(in), optional, target :: int logical, intent(in), optional :: resonant, mask_color type(quantum_numbers_t), intent(in), optional :: qn_filter_conn type(quantum_numbers_mask_t) :: mask type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_sf type(interaction_t), pointer :: src_int logical :: mask_c mask_c = .false. if (present (mask_color)) mask_c = mask_color mask = quantum_numbers_mask (.false., .false., .true.) if (present (int)) then src_int => int else src_int => isolated%sf_chain_eff%get_out_int_ptr () call state%flows_sf%init_color_contractions (src_int) state%has_flows_sf = .true. src_int => state%flows_sf%interaction_t if (mask_c) then allocate (mask_sf (src_int%get_n_tot ())) mask_sf = quantum_numbers_mask (.false., .true., .false.) call src_int%reduce_state_matrix (mask_sf, keep_order = .true.) end if end if call state%flows%init_product (src_int, isolated%flows, mask, & qn_filter_conn = qn_filter_conn, & connections_are_resonant = resonant) state%has_flows = .true. end subroutine connected_state_setup_connected_flows @ %def connected_state_setup_connected_flows @ Determine and store the flavor content for the connected state. This queries the [[matrix]] evaluator component, which should hold the requested flavor information. <>= procedure :: setup_state_flv => connected_state_setup_state_flv <>= module subroutine connected_state_setup_state_flv (state, n_out_hard) class(connected_state_t), intent(inout), target :: state integer, intent(in) :: n_out_hard end subroutine connected_state_setup_state_flv <>= module subroutine connected_state_setup_state_flv (state, n_out_hard) class(connected_state_t), intent(inout), target :: state integer, intent(in) :: n_out_hard call state%matrix%get_flv_content (state%state_flv, n_out_hard) end subroutine connected_state_setup_state_flv @ %def connected_state_setup_state_flv @ Return the current flavor state object. <>= procedure :: get_state_flv => connected_state_get_state_flv <>= module function connected_state_get_state_flv (state) result (state_flv) class(connected_state_t), intent(in) :: state type(state_flv_content_t) :: state_flv end function connected_state_get_state_flv <>= module function connected_state_get_state_flv (state) result (state_flv) class(connected_state_t), intent(in) :: state type(state_flv_content_t) :: state_flv state_flv = state%state_flv end function connected_state_get_state_flv @ %def connected_state_get_state_flv @ \subsection{Cuts and expressions} Set up the [[subevt]] that corresponds to the connected interaction. The index arrays refer to the interaction. We assign the particles as follows: the beam particles are the first two (decay process: one) entries in the trace evaluator. The incoming partons are identified by their link to the outgoing partons of the structure-function chain. The outgoing partons are those of the trace evaluator, which include radiated partons during the structure-function chain. <>= procedure :: setup_subevt => connected_state_setup_subevt <>= module subroutine connected_state_setup_subevt & (state, sf_chain, f_beam, f_in, f_out) class(connected_state_t), intent(inout), target :: state type(sf_chain_instance_t), intent(in), target :: sf_chain type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out end subroutine connected_state_setup_subevt <>= module subroutine connected_state_setup_subevt & (state, sf_chain, f_beam, f_in, f_out) class(connected_state_t), intent(inout), target :: state type(sf_chain_instance_t), intent(in), target :: sf_chain type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out integer :: n_beam, n_in, n_out, n_vir, n_tot, i, j integer, dimension(:), allocatable :: i_beam, i_in, i_out integer :: sf_out_i type(interaction_t), pointer :: sf_int sf_int => sf_chain%get_out_int_ptr () n_beam = size (f_beam) n_in = size (f_in) n_out = size (f_out) n_vir = state%trace%get_n_vir () n_tot = state%trace%get_n_tot () allocate (i_beam (n_beam), i_in (n_in), i_out (n_out)) i_beam = [(i, i = 1, n_beam)] do j = 1, n_in sf_out_i = sf_chain%get_out_i (j) i_in(j) = interaction_find_link & (state%trace%interaction_t, sf_int, sf_out_i) end do i_out = [(i, i = n_vir + 1, n_tot)] call state%expr%setup_subevt (state%trace%interaction_t, & i_beam, i_in, i_out, f_beam, f_in, f_out) state%has_expr = .true. end subroutine connected_state_setup_subevt @ %def connected_state_setup_subevt <>= procedure :: renew_flv_content_subevt => & connected_state_renew_flv_content_subevt <>= module subroutine connected_state_renew_flv_content_subevt & (state, sf_chain, f_beam, f_in, f_out) class(connected_state_t), intent(inout), target :: state type(sf_chain_instance_t), intent(in), target :: sf_chain type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out end subroutine connected_state_renew_flv_content_subevt <>= module subroutine connected_state_renew_flv_content_subevt & (state, sf_chain, f_beam, f_in, f_out) class(connected_state_t), intent(inout), target :: state type(sf_chain_instance_t), intent(in), target :: sf_chain type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out integer :: n_beam, n_in, n_out, n_vir, n_tot, i, j integer, dimension(:), allocatable :: i_beam, i_in, i_out integer :: sf_out_i type(interaction_t), pointer :: sf_int sf_int => sf_chain%get_out_int_ptr () n_beam = size (f_beam) n_in = size (f_in) n_out = size (f_out) n_vir = state%trace%get_n_vir () n_tot = state%trace%get_n_tot () allocate (i_beam (n_beam), i_in (n_in), i_out (n_out)) i_beam = [(i, i = 1, n_beam)] do j = 1, n_in sf_out_i = sf_chain%get_out_i (j) i_in(j) = interaction_find_link & (state%trace%interaction_t, sf_int, sf_out_i) end do i_out = [(i, i = n_vir + 1, n_tot)] call state%expr%renew_flv_content_subevt (state%trace%interaction_t, & i_beam, i_in, i_out, f_beam, f_in, f_out) state%has_expr = .true. end subroutine connected_state_renew_flv_content_subevt @ %def connected_state_setup_subevt @ Initialize the variable list specific for this state/term. We insert event variables ([[sqrts_hat]]) and link the process variable list. The variable list acquires pointers to subobjects of [[state]], which must therefore have a [[target]] attribute. <>= procedure :: setup_var_list => connected_state_setup_var_list <>= module subroutine connected_state_setup_var_list & (state, process_var_list, beam_data) class(connected_state_t), intent(inout), target :: state type(var_list_t), intent(in), target :: process_var_list type(beam_data_t), intent(in) :: beam_data end subroutine connected_state_setup_var_list <>= module subroutine connected_state_setup_var_list & (state, process_var_list, beam_data) class(connected_state_t), intent(inout), target :: state type(var_list_t), intent(in), target :: process_var_list type(beam_data_t), intent(in) :: beam_data call state%expr%setup_vars (beam_data%get_sqrts ()) call state%expr%link_var_list (process_var_list) end subroutine connected_state_setup_var_list @ %def connected_state_setup_var_list @ Allocate the cut expression etc. <>= procedure :: setup_cuts => connected_state_setup_cuts procedure :: setup_scale => connected_state_setup_scale procedure :: setup_fac_scale => connected_state_setup_fac_scale procedure :: setup_ren_scale => connected_state_setup_ren_scale procedure :: setup_weight => connected_state_setup_weight <>= module subroutine connected_state_setup_cuts (state, ef_cuts) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_cuts end subroutine connected_state_setup_cuts module subroutine connected_state_setup_scale (state, ef_scale) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_scale end subroutine connected_state_setup_scale module subroutine connected_state_setup_fac_scale (state, ef_fac_scale) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_fac_scale end subroutine connected_state_setup_fac_scale module subroutine connected_state_setup_ren_scale (state, ef_ren_scale) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_ren_scale end subroutine connected_state_setup_ren_scale module subroutine connected_state_setup_weight (state, ef_weight) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_weight end subroutine connected_state_setup_weight <>= module subroutine connected_state_setup_cuts (state, ef_cuts) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_cuts call state%expr%setup_selection (ef_cuts) end subroutine connected_state_setup_cuts module subroutine connected_state_setup_scale (state, ef_scale) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_scale call state%expr%setup_scale (ef_scale) end subroutine connected_state_setup_scale module subroutine connected_state_setup_fac_scale (state, ef_fac_scale) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_fac_scale call state%expr%setup_fac_scale (ef_fac_scale) end subroutine connected_state_setup_fac_scale module subroutine connected_state_setup_ren_scale (state, ef_ren_scale) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_ren_scale call state%expr%setup_ren_scale (ef_ren_scale) end subroutine connected_state_setup_ren_scale module subroutine connected_state_setup_weight (state, ef_weight) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_weight call state%expr%setup_weight (ef_weight) end subroutine connected_state_setup_weight @ %def connected_state_setup_expressions @ Reset the expression object: invalidate the subevt. <>= procedure :: reset_expressions => connected_state_reset_expressions <>= module subroutine connected_state_reset_expressions (state) class(connected_state_t), intent(inout) :: state end subroutine connected_state_reset_expressions <>= module subroutine connected_state_reset_expressions (state) class(connected_state_t), intent(inout) :: state if (state%has_expr) call state%expr%reset_contents () end subroutine connected_state_reset_expressions @ %def connected_state_reset_expressions @ \subsection{Evaluation} Transfer momenta to the trace evaluator and fill the [[subevt]] with this effective kinematics, if applicable. Note: we may want to apply a boost for the [[subevt]]. <>= procedure :: receive_kinematics => parton_state_receive_kinematics <>= module subroutine parton_state_receive_kinematics (state) class(parton_state_t), intent(inout), target :: state end subroutine parton_state_receive_kinematics <>= module subroutine parton_state_receive_kinematics (state) class(parton_state_t), intent(inout), target :: state if (state%has_trace) then call state%trace%receive_momenta () select type (state) class is (connected_state_t) if (state%has_expr) then call state%expr%fill_subevt (state%trace%interaction_t) end if end select end if end subroutine parton_state_receive_kinematics @ %def parton_state_receive_kinematics @ Recover kinematics: We assume that the trace evaluator is filled with momenta. Send those momenta back to the sources, then fill the variables and subevent as above. The incoming momenta of the connected state are not connected to the isolated state but to the beam interaction. Therefore, the incoming momenta within the isolated state do not become defined, yet. Instead, we reconstruct the beam (and ISR) momentum configuration. <>= procedure :: send_kinematics => parton_state_send_kinematics <>= module subroutine parton_state_send_kinematics (state) class(parton_state_t), intent(inout), target :: state end subroutine parton_state_send_kinematics <>= module subroutine parton_state_send_kinematics (state) class(parton_state_t), intent(inout), target :: state if (state%has_trace) then call state%trace%send_momenta () select type (state) class is (connected_state_t) call state%expr%fill_subevt (state%trace%interaction_t) end select end if end subroutine parton_state_send_kinematics @ %def parton_state_send_kinematics @ Evaluate the expressions. The routine evaluates first the cut expression. If the event passes, it evaluates the other expressions. Where no expressions are defined, default values are inserted. <>= procedure :: evaluate_expressions => connected_state_evaluate_expressions <>= module subroutine connected_state_evaluate_expressions (state, passed, & scale, fac_scale, ren_scale, weight, scale_forced, force_evaluation) class(connected_state_t), intent(inout) :: state logical, intent(out) :: passed real(default), intent(out) :: scale, weight real(default), intent(out), allocatable :: fac_scale, ren_scale real(default), intent(in), allocatable, optional :: scale_forced logical, intent(in), optional :: force_evaluation end subroutine connected_state_evaluate_expressions <>= module subroutine connected_state_evaluate_expressions (state, passed, & scale, fac_scale, ren_scale, weight, scale_forced, force_evaluation) class(connected_state_t), intent(inout) :: state logical, intent(out) :: passed real(default), intent(out) :: scale, weight real(default), intent(out), allocatable :: fac_scale, ren_scale real(default), intent(in), allocatable, optional :: scale_forced logical, intent(in), optional :: force_evaluation if (state%has_expr) then call state%expr%evaluate (passed, scale, fac_scale, ren_scale, weight, & scale_forced, force_evaluation) end if end subroutine connected_state_evaluate_expressions @ %def connected_state_evaluate_expressions @ Evaluate the structure-function chain, if it is allocated explicitly. The argument is the factorization scale. If the chain is merely a pointer, the chain should already be evaluated at this point. <>= procedure :: evaluate_sf_chain => isolated_state_evaluate_sf_chain <>= module subroutine isolated_state_evaluate_sf_chain (state, fac_scale) class(isolated_state_t), intent(inout) :: state real(default), intent(in) :: fac_scale end subroutine isolated_state_evaluate_sf_chain <>= module subroutine isolated_state_evaluate_sf_chain (state, fac_scale) class(isolated_state_t), intent(inout) :: state real(default), intent(in) :: fac_scale if (state%sf_chain_is_allocated) & call state%sf_chain_eff%evaluate (fac_scale) end subroutine isolated_state_evaluate_sf_chain @ %def isolated_state_evaluate_sf_chain @ Evaluate the trace. <>= procedure :: evaluate_trace => parton_state_evaluate_trace <>= module subroutine parton_state_evaluate_trace (state) class(parton_state_t), intent(inout) :: state end subroutine parton_state_evaluate_trace <>= module subroutine parton_state_evaluate_trace (state) class(parton_state_t), intent(inout) :: state if (state%has_trace) call state%trace%evaluate () end subroutine parton_state_evaluate_trace @ %def parton_state_evaluate_trace <>= procedure :: evaluate_matrix => parton_state_evaluate_matrix <>= module subroutine parton_state_evaluate_matrix (state) class(parton_state_t), intent(inout) :: state end subroutine parton_state_evaluate_matrix <>= module subroutine parton_state_evaluate_matrix (state) class(parton_state_t), intent(inout) :: state if (state%has_matrix) call state%matrix%evaluate () end subroutine parton_state_evaluate_matrix @ %def parton_state_evaluate_matrix @ Evaluate the extra evaluators that we need for physical events. <>= procedure :: evaluate_event_data => parton_state_evaluate_event_data <>= module subroutine parton_state_evaluate_event_data (state, only_momenta) class(parton_state_t), intent(inout) :: state logical, intent(in), optional :: only_momenta end subroutine parton_state_evaluate_event_data <>= module subroutine parton_state_evaluate_event_data (state, only_momenta) class(parton_state_t), intent(inout) :: state logical, intent(in), optional :: only_momenta logical :: only_mom only_mom = .false.; if (present (only_momenta)) only_mom = only_momenta select type (state) type is (connected_state_t) if (state%has_flows_sf) then call state%flows_sf%receive_momenta () if (.not. only_mom) call state%flows_sf%evaluate () end if end select if (state%has_matrix) then call state%matrix%receive_momenta () if (.not. only_mom) call state%matrix%evaluate () end if if (state%has_flows) then call state%flows%receive_momenta () if (.not. only_mom) call state%flows%evaluate () end if end subroutine parton_state_evaluate_event_data @ %def parton_state_evaluate_event_data @ Normalize the helicity density matrix by its trace, i.e., factor out the trace and put it into an overall normalization factor. The trace and flow evaluators are unchanged. <>= procedure :: normalize_matrix_by_trace => & parton_state_normalize_matrix_by_trace <>= module subroutine parton_state_normalize_matrix_by_trace (state) class(parton_state_t), intent(inout) :: state end subroutine parton_state_normalize_matrix_by_trace <>= module subroutine parton_state_normalize_matrix_by_trace (state) class(parton_state_t), intent(inout) :: state if (state%has_matrix) call state%matrix%normalize_by_trace () end subroutine parton_state_normalize_matrix_by_trace @ %def parton_state_normalize_matrix_by_trace @ \subsection{Accessing the state} Three functions return a pointer to the event-relevant interactions. <>= procedure :: get_trace_int_ptr => parton_state_get_trace_int_ptr procedure :: get_matrix_int_ptr => parton_state_get_matrix_int_ptr procedure :: get_flows_int_ptr => parton_state_get_flows_int_ptr <>= module function parton_state_get_trace_int_ptr (state) result (ptr) class(parton_state_t), intent(in), target :: state type(interaction_t), pointer :: ptr end function parton_state_get_trace_int_ptr module function parton_state_get_matrix_int_ptr (state) result (ptr) class(parton_state_t), intent(in), target :: state type(interaction_t), pointer :: ptr end function parton_state_get_matrix_int_ptr module function parton_state_get_flows_int_ptr (state) result (ptr) class(parton_state_t), intent(in), target :: state type(interaction_t), pointer :: ptr end function parton_state_get_flows_int_ptr <>= module function parton_state_get_trace_int_ptr (state) result (ptr) class(parton_state_t), intent(in), target :: state type(interaction_t), pointer :: ptr if (state%has_trace) then ptr => state%trace%interaction_t else ptr => null () end if end function parton_state_get_trace_int_ptr module function parton_state_get_matrix_int_ptr (state) result (ptr) class(parton_state_t), intent(in), target :: state type(interaction_t), pointer :: ptr if (state%has_matrix) then ptr => state%matrix%interaction_t else ptr => null () end if end function parton_state_get_matrix_int_ptr module function parton_state_get_flows_int_ptr (state) result (ptr) class(parton_state_t), intent(in), target :: state type(interaction_t), pointer :: ptr if (state%has_flows) then ptr => state%flows%interaction_t else ptr => null () end if end function parton_state_get_flows_int_ptr @ %def parton_state_get_trace_int_ptr @ %def parton_state_get_matrix_int_ptr @ %def parton_state_get_flows_int_ptr @ Return the indices of the beam particles and the outgoing particles within the trace (and thus, matrix and flows) evaluator, respectively. <>= procedure :: get_beam_index => connected_state_get_beam_index procedure :: get_in_index => connected_state_get_in_index <>= module subroutine connected_state_get_beam_index (state, i_beam) class(connected_state_t), intent(in) :: state integer, dimension(:), intent(out) :: i_beam end subroutine connected_state_get_beam_index module subroutine connected_state_get_in_index (state, i_in) class(connected_state_t), intent(in) :: state integer, dimension(:), intent(out) :: i_in end subroutine connected_state_get_in_index <>= module subroutine connected_state_get_beam_index (state, i_beam) class(connected_state_t), intent(in) :: state integer, dimension(:), intent(out) :: i_beam call state%expr%get_beam_index (i_beam) end subroutine connected_state_get_beam_index module subroutine connected_state_get_in_index (state, i_in) class(connected_state_t), intent(in) :: state integer, dimension(:), intent(out) :: i_in call state%expr%get_in_index (i_in) end subroutine connected_state_get_in_index @ %def connected_state_get_beam_index @ %def connected_state_get_in_index @ <>= public :: refill_evaluator <>= module subroutine refill_evaluator (sqme, qn, flv_index, evaluator) complex(default), intent(in), dimension(:) :: sqme type(quantum_numbers_t), intent(in), dimension(:,:) :: qn integer, intent(in), dimension(:), optional :: flv_index type(evaluator_t), intent(inout) :: evaluator end subroutine refill_evaluator <>= module subroutine refill_evaluator (sqme, qn, flv_index, evaluator) complex(default), intent(in), dimension(:) :: sqme type(quantum_numbers_t), intent(in), dimension(:,:) :: qn integer, intent(in), dimension(:), optional :: flv_index type(evaluator_t), intent(inout) :: evaluator integer :: i, i_flv do i = 1, size (sqme) if (present (flv_index)) then i_flv = flv_index(i) else i_flv = i end if call evaluator%add_to_matrix_element (qn(:,i_flv), sqme(i), & match_only_flavor = .true.) end do end subroutine refill_evaluator @ %def refill_evaluator @ Return the number of outgoing (hard) particles for the state. <>= procedure :: get_n_out => parton_state_get_n_out <>= module function parton_state_get_n_out (state) result (n) class(parton_state_t), intent(in), target :: state integer :: n end function parton_state_get_n_out <>= module function parton_state_get_n_out (state) result (n) class(parton_state_t), intent(in), target :: state integer :: n n = state%trace%get_n_out () end function parton_state_get_n_out @ %def parton_state_get_n_out @ \subsection{Unit tests} <<[[parton_states_ut.f90]]>>= <> module parton_states_ut use unit_tests use parton_states_uti <> <> contains <> end module parton_states_ut @ %def parton_states_ut <<[[parton_states_uti.f90]]>>= <> module parton_states_uti <> <> use constants, only: zero use numeric_utils use flavors use colors use helicities use quantum_numbers use sf_base, only: sf_chain_instance_t use state_matrices, only: state_matrix_t use prc_template_me, only: prc_template_me_t use interactions, only: interaction_t use models, only: model_t, create_test_model use parton_states <> <> contains <> end module parton_states_uti @ %def parton_states_uti @ <>= public :: parton_states_test <>= subroutine parton_states_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine parton_states_test @ %def parton_states_test @ \subsubsection{Test a simple isolated state} <>= call test (parton_states_1, "parton_states_1", & "Create a 2 -> 2 isolated state and compute trace", & u, results) <>= public :: parton_states_1 <>= subroutine parton_states_1 (u) integer, intent(in) :: u type(state_matrix_t), allocatable :: state type(flavor_t), dimension(2) :: flv_in type(flavor_t), dimension(2) :: flv_out1, flv_out2 type(flavor_t), dimension(4) :: flv_tot type(helicity_t), dimension(4) :: hel type(color_t), dimension(4) :: col integer :: h1, h2, h3, h4 integer :: f integer :: i type(quantum_numbers_t), dimension(4) :: qn type(prc_template_me_t) :: core type(sf_chain_instance_t), target :: sf_chain type(interaction_t), target :: int type(isolated_state_t) :: isolated_state integer :: n_states = 0 integer, dimension(:), allocatable :: col_flow_index type(quantum_numbers_mask_t), dimension(2) :: qn_mask integer, dimension(8) :: i_allowed_states complex(default), dimension(8) :: me complex(default) :: me_check_tot, me_check_1, me_check_2, me2 logical :: tmp1, tmp2 type(model_t), pointer :: test_model => null () write (u, "(A)") "* Test output: parton_states_1" write (u, "(A)") "* Purpose: Test the standard parton states" write (u, "(A)") call flv_in%init ([11, -11]) call flv_out1%init ([1, -1]) call flv_out2%init ([2, -2]) write (u, "(A)") "* Using incoming flavors: " call flavor_write_array (flv_in, u) write (u, "(A)") "* Two outgoing flavor structures: " call flavor_write_array (flv_out1, u) call flavor_write_array (flv_out2, u) write (u, "(A)") "* Initialize state matrix" allocate (state) call state%init () write (u, "(A)") "* Fill state matrix" call col(3)%init ([1]) call col(4)%init ([-1]) do f = 1, 2 do h1 = -1, 1, 2 do h2 = -1, 1, 2 do h3 = -1, 1, 2 do h4 = -1, 1, 2 n_states = n_states + 1 call hel%init ([h1, h2, h3, h4], [h1, h2, h3, h4]) if (f == 1) then flv_tot = [flv_in, flv_out1] else flv_tot = [flv_in, flv_out2] end if call qn%init (flv_tot, col, hel) call state%add_state (qn) end do end do end do end do end do !!! Two flavors, one color flow, 2 x 2 x 2 x 2 helicity configurations !!! -> 32 states. write (u, "(A)") write (u, "(A,I2)") "* Generated number of states: ", n_states call state%freeze () !!! Indices of the helicity configurations which are non-zero i_allowed_states = [6, 7, 10, 11, 22, 23, 26, 27] me = [cmplx (-1.89448E-5_default, 9.94456E-7_default, default), & cmplx (-8.37887E-2_default, 4.30842E-3_default, default), & cmplx (-1.99997E-1_default, -1.01985E-2_default, default), & cmplx ( 1.79717E-5_default, 9.27038E-7_default, default), & cmplx (-1.74859E-5_default, 8.78819E-7_default, default), & cmplx ( 1.67577E-1_default, -8.61683E-3_default, default), & cmplx ( 2.41331E-1_default, 1.23306E-2_default, default), & cmplx (-3.59435E-5_default, -1.85407E-6_default, default)] me_check_tot = cmplx (zero, zero, default) me_check_1 = cmplx (zero, zero, default) me_check_2 = cmplx (zero, zero, default) do i = 1, 8 me2 = me(i) * conjg (me(i)) me_check_tot = me_check_tot + me2 if (i < 5) then me_check_1 = me_check_1 + me2 else me_check_2 = me_check_2 + me2 end if call state%set_matrix_element (i_allowed_states(i), me(i)) end do !!! Do not forget the color factor me_check_tot = 3._default * me_check_tot me_check_1 = 3._default * me_check_1 me_check_2 = 3._default * me_check_2 write (u, "(A)") write (u, "(A)") "* Setup interaction" call int%basic_init (2, 0, 2, set_relations = .true.) call int%set_state_matrix (state) core%data%n_in = 2; core%data%n_out = 2 core%data%n_flv = 2 allocate (core%data%flv_state (4, 2)) core%data%flv_state (1, :) = [11, 11] core%data%flv_state (2, :) = [-11, -11] core%data%flv_state (3, :) = [1, 2] core%data%flv_state (4, :) = [-1, -2] core%use_color_factors = .false. core%nc = 3 write (u, "(A)") "* Init isolated state" call isolated_state%init (sf_chain, int) !!! There is only one color flow. allocate (col_flow_index (n_states)); col_flow_index = 1 call qn_mask%init (.false., .false., .true., mask_cg = .false.) write (u, "(A)") "* Give a trace to the isolated state" call isolated_state%setup_square_trace (core, qn_mask, col_flow_index, .false.) call isolated_state%evaluate_trace () write (u, "(A)") write (u, "(A)", advance = "no") "* Squared matrix element correct: " write (u, "(L1)") nearly_equal (me_check_tot, & isolated_state%trace%get_matrix_element (1), rel_smallness = 0.00001_default) write (u, "(A)") "* Give a matrix to the isolated state" call create_test_model (var_str ("SM"), test_model) call isolated_state%setup_square_matrix (core, test_model, qn_mask, col_flow_index) call isolated_state%evaluate_matrix () write (u, "(A)") "* Sub-matrixelements correct: " tmp1 = nearly_equal (me_check_1, & isolated_state%matrix%get_matrix_element (1), rel_smallness = 0.00001_default) tmp2 = nearly_equal (me_check_2, & isolated_state%matrix%get_matrix_element (2), rel_smallness = 0.00001_default) write (u, "(A,L1,A,L1)") "* 1: ", tmp1, ", 2: ", tmp2 write (u, "(A)") "* Test output end: parton_states_1" end subroutine parton_states_1 @ %def parton_states_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process component management} This module contains tools for managing and combining process components and matrix-element code and values, acting at a level below the actual process definition. \subsection{Abstract base type} The types introduced here are abstract base types. <<[[pcm_base.f90]]>>= <> module pcm_base <> <> use os_interface, only: os_data_t use process_libraries, only: process_library_t use prc_core_def use prc_core use variables, only: var_list_t use mappings, only: mapping_defaults_t use phs_base, only: phs_config_t use phs_forests, only: phs_parameters_t use mci_base, only: mci_t use model_data, only: model_data_t use models, only: model_t use blha_config, only: blha_master_t use blha_olp_interfaces, only: blha_template_t use process_config use process_mci, only: process_mci_entry_t <> <> <> <> <> interface <> end interface end module pcm_base @ %def pcm_base @ <<[[pcm_base_sub.f90]]>>= <> submodule (pcm_base) pcm_base_s use io_units use diagnostics use format_utils, only: write_integer_array use format_utils, only: write_separator use physics_defs, only: BORN, NLO_REAL implicit none contains <> end submodule pcm_base_s @ %def pcm_base_s @ \subsection{Core management} This object holds information about the cores used by the components and allocates the corresponding manager instance. [[i_component]] is the index of the process component which this core belongs to. The pointer to the core definition is a convenient help in configuring the core itself. We allow for a [[blha_config]] configuration object that covers BLHA cores. The BLHA standard is suitable generic to warrant support outside of specific type extension (i.e., applies to LO and NLO if requested). The BLHA configuration is allocated only if the core requires it. <>= public :: core_entry_t <>= type :: core_entry_t integer :: i_component = 0 logical :: active = .false. class(prc_core_def_t), pointer :: core_def => null () type(blha_template_t), allocatable :: blha_config class(prc_core_t), allocatable :: core contains <> end type core_entry_t @ %def core_entry_t @ <>= procedure :: get_core_ptr => core_entry_get_core_ptr <>= module function core_entry_get_core_ptr (core_entry) result (core) class(core_entry_t), intent(in), target :: core_entry class(prc_core_t), pointer :: core end function core_entry_get_core_ptr <>= module function core_entry_get_core_ptr (core_entry) result (core) class(core_entry_t), intent(in), target :: core_entry class(prc_core_t), pointer :: core if (allocated (core_entry%core)) then core => core_entry%core else core => null () end if end function core_entry_get_core_ptr @ %def core_entry_get_core_ptr @ Configure the core object after allocation with correct type. The [[core_def]] object pointer and the index [[i_component]] of the associated process component are already there. <>= procedure :: configure => core_entry_configure <>= module subroutine core_entry_configure (core_entry, lib, id) class(core_entry_t), intent(inout) :: core_entry type(process_library_t), intent(in), target :: lib type(string_t), intent(in) :: id end subroutine core_entry_configure <>= module subroutine core_entry_configure (core_entry, lib, id) class(core_entry_t), intent(inout) :: core_entry type(process_library_t), intent(in), target :: lib type(string_t), intent(in) :: id call core_entry%core%init & (core_entry%core_def, lib, id, core_entry%i_component) end subroutine core_entry_configure @ %def core_entry_configure @ \subsection{Process component manager} The process-component manager [[pcm]] is the master component of the [[process_t]] object. It serves two purposes: \begin{enumerate} \item It holds configuration data which allow us to centrally manage the components, terms, etc.\ of the process object. \item It implements the methods that realize the algorithm for constructing the process object and computing an integral. This algorithm makes use of the data stored within [[pcm]]. \end{enumerate} To this end, the object is abstract and polymorphic. The two extensions that we support, implement (a) default tree-level calculation, optionally including a sum over sub-processes with different particle content, or (b) the FKS-NLO subtraction algorithm for QCD-corrected processes. In both cases, the type extensions may hold suitable further data. Data included in the base type: The number of components determines the [[component_selected]] array. [[i_phs_config]] is a lookup table that holds the PHS configuration index for a given component index. [[i_core]] is a lookup table that holds the core-entry index for a given component index. [[i_mci]] is a lookup table that holds the integrator (MCI) index for a given component index. <>= public :: pcm_t <>= type, abstract :: pcm_t logical :: initialized = .false. logical :: has_pdfs = .false. integer :: n_components = 0 integer :: n_cores = 0 integer :: n_mci = 0 logical, dimension(:), allocatable :: component_selected logical, dimension(:), allocatable :: component_active integer, dimension(:), allocatable :: i_phs_config integer, dimension(:), allocatable :: i_core integer, dimension(:), allocatable :: i_mci type(blha_template_t) :: blha_defaults logical :: uses_blha = .false. type(os_data_t) :: os_data contains <> end type pcm_t @ %def pcm_t @ The factory method. We use the [[inout]] intent, so calling this again is an error. <>= procedure(pcm_allocate_workspace), deferred :: allocate_workspace <>= abstract interface subroutine pcm_allocate_workspace (pcm, work) import class(pcm_t), intent(in) :: pcm class(pcm_workspace_t), intent(inout), allocatable :: work end subroutine pcm_allocate_workspace end interface @ %def pcm_allocate_workspace @ <>= procedure(pcm_is_nlo), deferred :: is_nlo <>= abstract interface function pcm_is_nlo (pcm) result (is_nlo) import logical :: is_nlo class(pcm_t), intent(in) :: pcm end function pcm_is_nlo end interface @ %def pcm_is_nlo @ <>= procedure(pcm_final), deferred :: final <>= abstract interface subroutine pcm_final (pcm) import class(pcm_t), intent(inout) :: pcm end subroutine pcm_final end interface @ %def pcm_final @ \subsection{Initialization methods} The PCM has the duty to coordinate and configure the process-object components. Initialize the PCM configuration itself, using environment data. <>= procedure(pcm_init), deferred :: init <>= abstract interface subroutine pcm_init (pcm, env, meta) import class(pcm_t), intent(out) :: pcm type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta end subroutine pcm_init end interface @ %def pcm_init @ Initialize the BLHA configuration block, the component-independent default settings. This is to be called by [[pcm_init]]. We use the provided variable list. This block is filled regardless of whether BLHA is actually used, because why not? We use a default value for the scheme (not set in unit tests). <>= procedure :: set_blha_defaults => pcm_set_blha_defaults <>= module subroutine pcm_set_blha_defaults (pcm, polarized_beams, var_list) class(pcm_t), intent(inout) :: pcm type(var_list_t), intent(in) :: var_list logical, intent(in) :: polarized_beams end subroutine pcm_set_blha_defaults <>= module subroutine pcm_set_blha_defaults (pcm, polarized_beams, var_list) class(pcm_t), intent(inout) :: pcm type(var_list_t), intent(in) :: var_list logical, intent(in) :: polarized_beams logical :: muon_yukawa_off real(default) :: top_yukawa type(string_t) :: ew_scheme muon_yukawa_off = & var_list%get_lval (var_str ("?openloops_switch_off_muon_yukawa")) top_yukawa = & var_list%get_rval (var_str ("blha_top_yukawa")) ew_scheme = & var_list%get_sval (var_str ("$blha_ew_scheme")) if (ew_scheme == "") ew_scheme = "Gmu" call pcm%blha_defaults%init & (polarized_beams, muon_yukawa_off, top_yukawa, ew_scheme) end subroutine pcm_set_blha_defaults @ %def pcm_set_blha_defaults @ Read the method settings from the variable list and store them in the BLHA master. The details depend on the [[pcm]] concrete type. <>= procedure(pcm_set_blha_methods), deferred :: set_blha_methods <>= abstract interface subroutine pcm_set_blha_methods (pcm, blha_master, var_list) import class(pcm_t), intent(inout) :: pcm type(blha_master_t), intent(inout) :: blha_master type(var_list_t), intent(in) :: var_list end subroutine pcm_set_blha_methods end interface @ %def pcm_set_blha_methods @ Produce the LO and NLO flavor-state tables (as far as available), as appropriate for BLHA configuration. We may inspect either the PCM itself or the array of process cores. <>= procedure(pcm_get_blha_flv_states), deferred :: get_blha_flv_states <>= abstract interface subroutine pcm_get_blha_flv_states (pcm, core_entry, flv_born, flv_real) import class(pcm_t), intent(in) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry integer, dimension(:,:), allocatable, intent(out) :: flv_born integer, dimension(:,:), allocatable, intent(out) :: flv_real end subroutine pcm_get_blha_flv_states end interface @ %def pcm_get_blha_flv_states @ Allocate the right number of process components. The number is also stored in the process meta. Initially, all components are active but none are selected. <>= procedure :: allocate_components => pcm_allocate_components <>= module subroutine pcm_allocate_components (pcm, comp, meta) class(pcm_t), intent(inout) :: pcm type(process_component_t), dimension(:), allocatable, intent(out) :: comp type(process_metadata_t), intent(in) :: meta end subroutine pcm_allocate_components <>= module subroutine pcm_allocate_components (pcm, comp, meta) class(pcm_t), intent(inout) :: pcm type(process_component_t), dimension(:), allocatable, intent(out) :: comp type(process_metadata_t), intent(in) :: meta pcm%n_components = meta%n_components allocate (comp (pcm%n_components)) allocate (pcm%component_selected (pcm%n_components), source = .false.) allocate (pcm%component_active (pcm%n_components), source = .true.) end subroutine pcm_allocate_components @ %def pcm_allocate_components @ Each process component belongs to a category/type, which we identify by a universal integer constant. The categories can be taken from the process definition. For easy lookup, we store the categories in an array. <>= procedure(pcm_categorize_components), deferred :: categorize_components <>= abstract interface subroutine pcm_categorize_components (pcm, config) import class(pcm_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config end subroutine pcm_categorize_components end interface @ %def pcm_categorize_components @ Allocate the right number and type(s) of process-core objects, i.e., the interface object between the process and matrix-element code. Within the [[pcm]] block, also associate cores with components and store relevant configuration data, including the [[i_core]] lookup table. <>= procedure(pcm_allocate_cores), deferred :: allocate_cores <>= abstract interface subroutine pcm_allocate_cores (pcm, config, core_entry) import class(pcm_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry end subroutine pcm_allocate_cores end interface @ %def pcm_allocate_cores @ Generate and interface external code for a single core, if this is required. <>= procedure(pcm_prepare_any_external_code), deferred :: & prepare_any_external_code <>= abstract interface subroutine pcm_prepare_any_external_code & (pcm, core_entry, i_core, libname, model, var_list) import class(pcm_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry integer, intent(in) :: i_core type(string_t), intent(in) :: libname type(model_data_t), intent(in), target :: model type(var_list_t), intent(in) :: var_list end subroutine pcm_prepare_any_external_code end interface @ %def pcm_prepare_any_external_code @ Prepare the BLHA configuration for a core object that requires it. This does not affect the core object, which may not yet be allocated. <>= procedure(pcm_setup_blha), deferred :: setup_blha <>= abstract interface subroutine pcm_setup_blha (pcm, core_entry) import class(pcm_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry end subroutine pcm_setup_blha end interface @ %def pcm_setup_blha @ Configure the BLHA interface for a core object that requires it. This is separate from the previous method, assuming that the [[pcm]] has to allocate the actual cores and acquire some data in-between. <>= procedure(pcm_prepare_blha_core), deferred :: prepare_blha_core <>= abstract interface subroutine pcm_prepare_blha_core (pcm, core_entry, model) import class(pcm_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry class(model_data_t), intent(in), target :: model end subroutine pcm_prepare_blha_core end interface @ %def pcm_prepare_blha_core @ Allocate and configure the MCI (multi-channel integrator) records and their relation to process components, appropriate for the algorithm implemented by [[pcm]]. Create a [[mci_t]] template: the procedure [[dispatch_mci]] is called as a factory method for allocating the [[mci_t]] object with a specific concrete type. The call may depend on the concrete [[pcm]] type. <>= public :: dispatch_mci_proc <>= abstract interface subroutine dispatch_mci_proc (mci, var_list, process_id, is_nlo) import class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo end subroutine dispatch_mci_proc end interface @ %def dispatch_mci_proc <>= procedure(pcm_setup_mci), deferred :: setup_mci procedure(pcm_call_dispatch_mci), deferred :: call_dispatch_mci <>= abstract interface subroutine pcm_setup_mci (pcm, mci_entry) import class(pcm_t), intent(inout) :: pcm type(process_mci_entry_t), & dimension(:), allocatable, intent(out) :: mci_entry end subroutine pcm_setup_mci end interface abstract interface subroutine pcm_call_dispatch_mci (pcm, & dispatch_mci, var_list, process_id, mci_template) import class(pcm_t), intent(inout) :: pcm procedure(dispatch_mci_proc) :: dispatch_mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id class(mci_t), intent(out), allocatable :: mci_template end subroutine pcm_call_dispatch_mci end interface @ %def pcm_setup_mci @ %def pcm_call_dispatch_mci @ Proceed with PCM configuration based on the core and component configuration data. Base version is empty. <>= procedure(pcm_complete_setup), deferred :: complete_setup <>= abstract interface subroutine pcm_complete_setup (pcm, core_entry, component, model) import class(pcm_t), intent(inout) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry type(process_component_t), dimension(:), intent(inout) :: component type(model_t), intent(in), target :: model end subroutine pcm_complete_setup end interface @ %def pcm_complete_setup @ \subsubsection{Retrieve information} Return the core index that belongs to a particular component. <>= procedure :: get_i_core => pcm_get_i_core <>= module function pcm_get_i_core (pcm, i_component) result (i_core) class(pcm_t), intent(in) :: pcm integer, intent(in) :: i_component integer :: i_core end function pcm_get_i_core <>= module function pcm_get_i_core (pcm, i_component) result (i_core) class(pcm_t), intent(in) :: pcm integer, intent(in) :: i_component integer :: i_core if (allocated (pcm%i_core)) then i_core = pcm%i_core(i_component) else i_core = 0 end if end function pcm_get_i_core @ %def pcm_get_i_core @ \subsubsection{Phase-space configuration} Allocate and initialize the right number and type(s) of phase-space configuration entries. The [[i_phs_config]] lookup table must be set accordingly. <>= procedure(pcm_init_phs_config), deferred :: init_phs_config <>= abstract interface subroutine pcm_init_phs_config & (pcm, phs_entry, meta, env, phs_par, mapping_defs) import class(pcm_t), intent(inout) :: pcm type(process_phs_config_t), & dimension(:), allocatable, intent(out) :: phs_entry type(process_metadata_t), intent(in) :: meta type(process_environment_t), intent(in) :: env type(mapping_defaults_t), intent(in) :: mapping_defs type(phs_parameters_t), intent(in) :: phs_par end subroutine pcm_init_phs_config end interface @ %def pcm_init_phs_config @ Initialize a single component. We require all process-configuration blocks, and specific templates for the phase-space and integrator configuration. We also provide the current component index [[i]] and the [[active]] flag. <>= procedure(pcm_init_component), deferred :: init_component <>= abstract interface subroutine pcm_init_component & (pcm, component, i, active, phs_config, env, meta, config) import class(pcm_t), intent(in) :: pcm type(process_component_t), intent(out) :: component integer, intent(in) :: i logical, intent(in) :: active class(phs_config_t), allocatable, intent(in) :: phs_config type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta type(process_config_data_t), intent(in) :: config end subroutine pcm_init_component end interface @ %def pcm_init_component @ Record components in the process [[meta]] data if they have turned out to be inactive. <>= procedure :: record_inactive_components => pcm_record_inactive_components <>= module subroutine pcm_record_inactive_components (pcm, component, meta) class(pcm_t), intent(inout) :: pcm type(process_component_t), dimension(:), intent(in) :: component type(process_metadata_t), intent(inout) :: meta end subroutine pcm_record_inactive_components <>= module subroutine pcm_record_inactive_components (pcm, component, meta) class(pcm_t), intent(inout) :: pcm type(process_component_t), dimension(:), intent(in) :: component type(process_metadata_t), intent(inout) :: meta integer :: i pcm%component_active = component%active do i = 1, pcm%n_components if (.not. component(i)%active) call meta%deactivate_component (i) end do end subroutine pcm_record_inactive_components @ %def pcm_record_inactive_components @ \subsection{Manager workspace} This object deals with the actual (squared) matrix element values. It holds any central data that are generated and/or used when calculating a particular phase-space point. Since phase-space points are associated with an integrator, we expect the instances of this type to correspond to MCI instances. <>= public :: pcm_workspace_t <>= type, abstract :: pcm_workspace_t ! class(pcm_t), pointer :: config => null () logical :: bad_point = .false. contains <> end type pcm_workspace_t @ %def pcm_workspace_t @ <>= procedure(pcm_work_final), deferred :: final <>= abstract interface subroutine pcm_work_final (pcm_work) import class(pcm_workspace_t), intent(inout) :: pcm_work end subroutine pcm_work_final end interface @ %def pcm_work_final @ <>= procedure(pcm_work_is_nlo), deferred :: is_nlo <>= abstract interface function pcm_work_is_nlo (pcm_work) result (is_nlo) import logical :: is_nlo class(pcm_workspace_t), intent(inout) :: pcm_work end function pcm_work_is_nlo end interface @ %def pcm_work_is_nlo @ <>= procedure :: link_config => pcm_work_link_config <>= subroutine pcm_work_link_config (pcm_work, config) class(pcm_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in), target :: config pcm_work%config => config end subroutine pcm_work_link_config @ %def pcm_work_link_config @ <>= procedure :: is_valid => pcm_work_is_valid <>= module function pcm_work_is_valid (pcm_work) result (valid) logical :: valid class(pcm_workspace_t), intent(in) :: pcm_work end function pcm_work_is_valid <>= module function pcm_work_is_valid (pcm_work) result (valid) logical :: valid class(pcm_workspace_t), intent(in) :: pcm_work valid = .not. pcm_work%bad_point end function pcm_work_is_valid @ %def pcm_work_is_valid @ <>= procedure :: set_bad_point => pcm_work_set_bad_point <>= pure module subroutine pcm_work_set_bad_point (pcm_work, bad_point) class(pcm_workspace_t), intent(inout) :: pcm_work logical, intent(in) :: bad_point end subroutine pcm_work_set_bad_point <>= pure module subroutine pcm_work_set_bad_point (pcm_work, bad_point) class(pcm_workspace_t), intent(inout) :: pcm_work logical, intent(in) :: bad_point pcm_work%bad_point = pcm_work%bad_point .or. bad_point end subroutine pcm_work_set_bad_point @ %def pcm_work_set_bad_point @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{The process object} <<[[process.f90]]>>= <> module process <> <> <> use diagnostics use lorentz use rng_base use dispatch_rng, only: dispatch_rng_factory use dispatch_rng, only: update_rng_seed_in_var_list use os_interface use sm_qcd use mci_base use flavors use model_data use models use process_libraries use process_constants use variables use beam_structures use beams use pdg_arrays use expr_base use sf_base use sf_mappings use resonances, only: resonance_history_t, resonance_history_set_t use prc_test_core, only: test_t use prc_core_def, only: prc_core_def_t use prc_core, only: prc_core_t, helicity_selection_t use phs_base use parton_states, only: connected_state_t use pcm_base use pcm use process_counter use process_config use process_mci <> <> <> <> interface <> end interface contains <> end module process @ %def process @ <<[[process_sub.f90]]>>= <> submodule (process) process_s use io_units use format_utils, only: write_separator use constants use numeric_utils use cputime use md5 use integration_results use physics_defs use interactions use particles use dispatch_phase_space, only: dispatch_phs use prc_external, only: prc_external_t use prc_recola, only: prc_recola_t use blha_olp_interfaces, only: prc_blha_t, blha_template_t use prc_threshold, only: prc_threshold_t use phs_fks, only: phs_fks_config_t use mappings, only: mapping_defaults_t use phs_forests, only: phs_parameters_t use phs_wood, only: phs_wood_config_t use blha_config, only: blha_master_t implicit none contains <> end submodule process_s @ %def process_s @ \subsection{Process status} Store counter and status information in a process object. <>= type :: process_status_t private end type process_status_t @ %def process_status_t @ \subsection{Process status} Store integration results in a process object. <>= type :: process_results_t private end type process_results_t @ %def process_results_t @ \subsection{The process type} NOTE: The description below represents the intended structure after refactoring and disentangling the FKS-NLO vs. LO algorithm dependencies. A [[process]] object is the internal representation of integration-run methods and data, as they are controlled by the user via a Sindarin script. The process object provides access to matrix elements (the actual ``process'' definitions that the user has provided before), it defines the separation into individually integrable components, and it manages phase-space construction, the actual integration over phase space, and the accumulation of results. As a workspace for individual sampling calls, we introduce an associated [[process_instance]] object type elsewhere. The [[process]] object contains data that either define the configuration or accumulate results from a complete integration pass. After successful phase-space integration, subsequent event generation is not actually represented by the [[process]] object. However, any event generation refers to an existing [[process]] object which represents a specific integration pass, and it uses a fresh [[process_instance]] workspace for calculations. The process object consists of several subobjects with their specific purposes. The corresponding types are defined below. (Technically, the subobject type definitions have to come before the process type definition, but with NOWEB magic we reverse this order here.) The [[meta]] object describes the process globally. All contents become fixed when the object is initialized. Similarly, the [[env]] component captures the (Sindarin) environment at the point where the process object is initialized. The [[config]] object holds physical and technical configuration data that are collected and derived from the environment during process initialization, and which are common to all process components. The [[pcm]] object (process-component manager) is polymorphic. This is an object which holds data which represent the process-object structure and breakdown, and it contains the methods that implement the algorithm of managing this structure, accumulating partial results, and finally collecting the pieces. Depending on the generic process type, the contents of [[pcm]] do vary. In particular, there is some base-type data content and a simple (default) extension which is designed for traditional \oMega\ matrix elements and tree-level integration, possibly with several sub-processes to sum over. The second extension is designed for the FKS phase-space and subtraction algorithm for NLO QCD, which interfaces external one-loop providers. The [[component]] subobjects are, first of all, interfaces to the original process-component definitions that have been provided by the user, which the program has already taken to produce matrix-element code and interfaces. The management of those components is deferred by [[pcm]], which contains the information that defines the role of each component. In particular, in the default (LO) version, process components correspond to distinct particle combinations which have been included in the original process definition. In the FKS-NLO version, the breakdown of a NLO process into Born, real, virtual, etc.\ components determines the setup. The [[phs_config]] subobjects hold data that allow and implement the construction of phase-space configurations. The type [[process_phs_config_t]] is a wrapper type around the concrete polymorphic [[phs_config_t]] object type, which manages phase-space construction, including some bookkeeping required for setting up multi-channel integration. In the LO case, we expect a separate entry for each independent sub-process. For the FKS-NLO algorithm, we expect several entries: a default-type entry which implements the underlying Born phase space, and additional entries which enable the construction of various real-radiation and subtraction kinematics configurations. A [[core_entry]] is the interface to existing matrix-element and interaction code. Depending on the process and its components, there may be various distinct matrix elements to compute. The [[mci_entry]] objects configure distinct MC input parameter sets and their associated (multi-channel) integrators. The [[rng_factory]] object is a single objects which constructs individual random-number generators for various tasks, in a uniform and well-defined way. The [[beam_config]] object describes the incoming particles, either the decay mother or the scattering beams. It also contains the spectrum- and structure-function setup, which has to interact with the phase-space and integrator facilities. The [[term]] subobjects break down the process in its smallest parts which appear in the calculation. For LO processes, the correspondence between terms and components is one-to-one. The FKS-NLO algorithm requires not just separation of Born, real, and virtual components but also subtraction terms, and a decomposition of the real phase space into singular regions. The general idea is that the integration results of distinct sets of terms are summed over to provide the results of individual components. This is also controlled by the [[pcm]] subobject. The [[process_status]] object is a bookkeeping device that allows us to query the status of an ongoing calculation. The [[process_results]] object collects the integration results for external use, including integration history information. <>= public :: process_t <>= type :: process_t private type(process_metadata_t) :: & meta type(process_environment_t) :: & env type(process_config_data_t) :: & config class(pcm_t), allocatable :: & pcm type(process_component_t), dimension(:), allocatable :: & component type(process_phs_config_t), dimension(:), allocatable :: & phs_entry type(core_entry_t), dimension(:), allocatable :: & core_entry type(process_mci_entry_t), dimension(:), allocatable :: & mci_entry class(rng_factory_t), allocatable :: & rng_factory type(process_beam_config_t) :: & beam_config type(process_term_t), dimension(:), allocatable :: & term type(process_status_t) :: & status type(process_results_t) :: & result contains <> end type process_t @ %def process_t @ \subsection{Process pointer} Wrapper type for storing pointers to process objects in arrays. <>= public :: process_ptr_t <>= type :: process_ptr_t type(process_t), pointer :: p => null () end type process_ptr_t @ %def process_ptr_t @ \subsection{Output} This procedure is an important debugging and inspection tool; it is not used during normal operation. The process object is written to a file (identified by unit, which may also be standard output). Optional flags determine whether we show everything or just the interesting parts. The shorthand as a traditional TBP. <>= procedure :: write => process_write <>= module subroutine process_write (process, screen, unit, & show_os_data, show_var_list, show_rng, show_expressions, pacify) class(process_t), intent(in) :: process logical, intent(in) :: screen integer, intent(in), optional :: unit logical, intent(in), optional :: show_os_data logical, intent(in), optional :: show_var_list logical, intent(in), optional :: show_rng logical, intent(in), optional :: show_expressions logical, intent(in), optional :: pacify end subroutine process_write <>= module subroutine process_write (process, screen, unit, & show_os_data, show_var_list, show_rng, show_expressions, pacify) class(process_t), intent(in) :: process logical, intent(in) :: screen integer, intent(in), optional :: unit logical, intent(in), optional :: show_os_data logical, intent(in), optional :: show_var_list logical, intent(in), optional :: show_rng logical, intent(in), optional :: show_expressions logical, intent(in), optional :: pacify integer :: u, iostat character(0) :: iomsg integer, dimension(:), allocatable :: v_list u = given_output_unit (unit) allocate (v_list (0)) call set_flag (v_list, F_SHOW_OS_DATA, show_os_data) call set_flag (v_list, F_SHOW_VAR_LIST, show_var_list) call set_flag (v_list, F_SHOW_RNG, show_rng) call set_flag (v_list, F_SHOW_EXPRESSIONS, show_expressions) call set_flag (v_list, F_PACIFY, pacify) if (screen) then call process%write_formatted (u, "LISTDIRECTED", v_list, iostat, iomsg) else call process%write_formatted (u, "DT", v_list, iostat, iomsg) end if end subroutine process_write @ %def process_write @ Standard DTIO procedure with binding. For the particular application, the screen format is triggered by the [[LISTDIRECTED]] option for the [[iotype]] format editor string. The other options activate when the particular parameter value is found in [[v_list]]. NOTE: The DTIO [[generic]] binding is supported by gfortran since 7.0. TODO wk 2018: The default could be to show everything, and we should have separate switches for all major parts. Currently, there are only a few. <>= ! generic :: write (formatted) => write_formatted procedure :: write_formatted => process_write_formatted <>= module subroutine process_write_formatted (dtv, unit, iotype, & v_list, iostat, iomsg) class(process_t), intent(in) :: dtv integer, intent(in) :: unit character(*), intent(in) :: iotype integer, dimension(:), intent(in) :: v_list integer, intent(out) :: iostat character(*), intent(inout) :: iomsg end subroutine process_write_formatted <>= module subroutine process_write_formatted (dtv, unit, iotype, & v_list, iostat, iomsg) class(process_t), intent(in) :: dtv integer, intent(in) :: unit character(*), intent(in) :: iotype integer, dimension(:), intent(in) :: v_list integer, intent(out) :: iostat character(*), intent(inout) :: iomsg integer :: u logical :: screen logical :: var_list logical :: rng_factory logical :: expressions logical :: counters logical :: os_data logical :: model logical :: pacify integer :: i u = unit select case (iotype) case ("LISTDIRECTED") screen = .true. case default screen = .false. end select var_list = flagged (v_list, F_SHOW_VAR_LIST) rng_factory = flagged (v_list, F_SHOW_RNG, .true.) expressions = flagged (v_list, F_SHOW_EXPRESSIONS) counters = .true. os_data = flagged (v_list, F_SHOW_OS_DATA) model = .false. pacify = flagged (v_list, F_PACIFY) associate (process => dtv) if (screen) then write (msg_buffer, "(A)") repeat ("-", 72) call msg_message () else call write_separator (u, 2) end if call process%meta%write (u, screen) if (var_list) then call process%env%write (u, show_var_list=var_list, & show_model=.false., show_lib=.false., & show_os_data=os_data) else if (.not. screen) then write (u, "(1x,A)") "Variable list: [not shown]" end if if (process%meta%type == PRC_UNKNOWN) then call write_separator (u, 2) return else if (screen) then return end if call write_separator (u) call process%config%write (u, counters, model, expressions) if (rng_factory) then if (allocated (process%rng_factory)) then call write_separator (u) call process%rng_factory%write (u) end if end if call write_separator (u, 2) if (allocated (process%component)) then write (u, "(1x,A)") "Process component configuration:" do i = 1, size (process%component) call write_separator (u) call process%component(i)%write (u) end do else write (u, "(1x,A)") "Process component configuration: [undefined]" end if call write_separator (u, 2) if (allocated (process%term)) then write (u, "(1x,A)") "Process term configuration:" do i = 1, size (process%term) call write_separator (u) call process%term(i)%write (u) end do else write (u, "(1x,A)") "Process term configuration: [undefined]" end if call write_separator (u, 2) call process%beam_config%write (u) call write_separator (u, 2) if (allocated (process%mci_entry)) then write (u, "(1x,A)") "Multi-channel integrator configurations:" do i = 1, size (process%mci_entry) call write_separator (u) write (u, "(1x,A,I0,A)") "MCI #", i, ":" call process%mci_entry(i)%write (u, pacify) end do end if call write_separator (u, 2) end associate iostat = 0 iomsg = "" end subroutine process_write_formatted @ %def process_write_formatted @ <>= procedure :: write_meta => process_write_meta <>= module subroutine process_write_meta (process, unit, testflag) class(process_t), intent(in) :: process integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine process_write_meta <>= module subroutine process_write_meta (process, unit, testflag) class(process_t), intent(in) :: process integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u, i u = given_output_unit (unit) select case (process%meta%type) case (PRC_UNKNOWN) write (u, "(1x,A)") "Process instance [undefined]" return case (PRC_DECAY) write (u, "(1x,A)", advance="no") "Process instance [decay]:" case (PRC_SCATTERING) write (u, "(1x,A)", advance="no") "Process instance [scattering]:" case default call msg_bug ("process_instance_write: undefined process type") end select write (u, "(1x,A,A,A)") "'", char (process%meta%id), "'" write (u, "(3x,A,A,A)") "Run ID = '", char (process%meta%run_id), "'" if (allocated (process%meta%component_id)) then write (u, "(3x,A)") "Process components:" do i = 1, size (process%meta%component_id) if (process%pcm%component_selected(i)) then write (u, "(3x,'*')", advance="no") else write (u, "(4x)", advance="no") end if write (u, "(1x,I0,9A)") i, ": '", & char (process%meta%component_id (i)), "': ", & char (process%meta%component_description (i)) end do end if end subroutine process_write_meta @ %def process_write_meta @ Screen output. Write a short account of the process configuration and the current results. The verbose version lists the components, the short version just the results. <>= procedure :: show => process_show <>= module subroutine process_show (object, unit, verbose) class(process_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine process_show <>= module subroutine process_show (object, unit, verbose) class(process_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u logical :: verb real(default) :: err_percent u = given_output_unit (unit) verb = .true.; if (present (verbose)) verb = verbose if (verb) then call object%meta%show (u, object%config%model%get_name ()) select case (object%meta%type) case (PRC_DECAY) write (u, "(2x,A)", advance="no") "Computed width =" case (PRC_SCATTERING) write (u, "(2x,A)", advance="no") "Computed cross section =" case default; return end select else if (object%meta%run_id /= "") then write (u, "('Run',1x,A,':',1x)", advance="no") & char (object%meta%run_id) end if write (u, "(A)", advance="no") char (object%meta%id) select case (object%meta%num_id) case (0) write (u, "(':')") case default write (u, "(1x,'(',I0,')',':')") object%meta%num_id end select write (u, "(2x)", advance="no") end if if (object%has_integral_tot ()) then write (u, "(ES14.7,1x,'+-',ES9.2)", advance="no") & object%get_integral_tot (), object%get_error_tot () select case (object%meta%type) case (PRC_DECAY) write (u, "(1x,A)", advance="no") "GeV" case (PRC_SCATTERING) write (u, "(1x,A)", advance="no") "fb " case default write (u, "(1x,A)", advance="no") " " end select if (object%get_integral_tot () /= 0) then err_percent = abs (100 & * object%get_error_tot () / object%get_integral_tot ()) else err_percent = 0 end if if (err_percent == 0) then write (u, "(1x,'(',F4.0,4x,'%)')") err_percent else if (err_percent < 0.1) then write (u, "(1x,'(',F7.3,1x,'%)')") err_percent else if (err_percent < 1) then write (u, "(1x,'(',F6.2,2x,'%)')") err_percent else if (err_percent < 10) then write (u, "(1x,'(',F5.1,3x,'%)')") err_percent else write (u, "(1x,'(',F4.0,4x,'%)')") err_percent end if else write (u, "(A)") "[integral undefined]" end if end subroutine process_show @ %def process_show @ Finalizer. Explicitly iterate over all subobjects that may contain allocated pointers. TODO wk 2018 (workaround): The finalizer for the [[config_data]] component is not called. The reason is that this deletes model data local to the process, but these could be referenced by pointers (flavor objects) from some persistent event record. Obviously, such side effects should be avoided, but this requires refactoring the event-handling procedures. <>= procedure :: final => process_final <>= module subroutine process_final (process) class(process_t), intent(inout) :: process end subroutine process_final <>= module subroutine process_final (process) class(process_t), intent(inout) :: process integer :: i ! call process%meta%final () call process%env%final () ! call process%config%final () if (allocated (process%component)) then do i = 1, size (process%component) call process%component(i)%final () end do end if if (allocated (process%term)) then do i = 1, size (process%term) call process%term(i)%final () end do end if call process%beam_config%final () if (allocated (process%mci_entry)) then do i = 1, size (process%mci_entry) call process%mci_entry(i)%final () end do end if if (allocated (process%pcm)) then call process%pcm%final () deallocate (process%pcm) end if end subroutine process_final @ %def process_final @ \subsubsection{Process setup} Initialize a process. We need a process library [[lib]] and the process identifier [[proc_id]] (string). We will fetch the current run ID from the variable list [[var_list]]. We collect all important data from the environment and store them in the appropriate places. OS data, model, and variable list are copied into [[env]] (true snapshot), also the process library (pointer only). The [[meta]] subobject is initialized with process ID and attributes taken from the process library. We initialize the [[config]] subobject with all data that are relevant for this run, using the settings from [[env]]. These data determine the MD5 sum for this run, which allows us to identify the setup and possibly skips in a later re-run. We also allocate and initialize the embedded RNG factory. We take the seed from the [[var_list]], and we should return the [[var_list]] to the caller with a new seed. Finally, we allocate the process component manager [[pcm]], which implements the chosen algorithm for process integration. The first task of the manager is to allocate the component array and to determine the component categories (e.g., Born/Virtual etc.). TODO wk 2018: The [[pcm]] dispatcher should be provided by the caller, if we eventually want to eliminate dependencies on concrete [[pcm_t]] extensions. Gfortran 7/8/9 bug, has to remain in the main module: <>= procedure :: init => process_init <>= subroutine process_init & (process, proc_id, lib, os_data, model, var_list, beam_structure) class(process_t), intent(out) :: process type(string_t), intent(in) :: proc_id type(process_library_t), intent(in), target :: lib type(os_data_t), intent(in) :: os_data class(model_t), intent(in), target :: model type(var_list_t), intent(inout), target, optional :: var_list type(beam_structure_t), intent(in), optional :: beam_structure integer :: next_rng_seed if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_init") associate & (meta => process%meta, env => process%env, config => process%config) call env%init & (model, lib, os_data, var_list, beam_structure) call meta%init & (proc_id, lib, env%get_var_list_ptr ()) call config%init & (meta, env) call dispatch_rng_factory & (process%rng_factory, env%get_var_list_ptr (), next_rng_seed) call update_rng_seed_in_var_list (var_list, next_rng_seed) call dispatch_pcm & (process%pcm, config%process_def%is_nlo ()) associate (pcm => process%pcm) call pcm%init (env, meta) call pcm%allocate_components (process%component, meta) call pcm%categorize_components (config) end associate end associate end subroutine process_init @ %def process_init @ \subsection{Process component manager} The [[pcm]] (read: process-component manager) takes the responsibility of steering the actual algorithm of configuration and integration. Depending on the concrete type, different algorithms can be implemented. The first version of this supports just two implementations: leading-order (tree-level) integration and event generation, and NLO (QCD/FKS subtraction). We thus can start with a single logical for steering the dispatcher. TODO wk 2018: Eventually, we may eliminate all references to the extensions of [[pcm_t]] from this module and therefore move this outside the module as well. Gfortran 7/8/9 bug, has to be in the main module: <>= subroutine dispatch_pcm (pcm, is_nlo) class(pcm_t), allocatable, intent(out) :: pcm logical, intent(in) :: is_nlo if (.not. is_nlo) then allocate (pcm_default_t :: pcm) else allocate (pcm_nlo_t :: pcm) end if end subroutine dispatch_pcm @ %def dispatch_pcm @ This step is performed after phase-space and core objects are done: collect all missing information and prepare the process component manager for the appropriate integration algorithm. <>= procedure :: complete_pcm_setup => process_complete_pcm_setup <>= module subroutine process_complete_pcm_setup (process) class(process_t), intent(inout) :: process end subroutine process_complete_pcm_setup <>= module subroutine process_complete_pcm_setup (process) class(process_t), intent(inout) :: process call process%pcm%complete_setup & (process%core_entry, process%component, process%env%get_model_ptr ()) end subroutine process_complete_pcm_setup @ %def process_complete_pcm_setup @ \subsection{Core management} Allocate cores (interface objects to matrix-element code). The [[dispatch_core]] procedure is taken as an argument, so we do not depend on the implementation, and thus on the specific core types. The [[helicity_selection]] object collects data that the matrix-element code needs for configuring the appropriate behavior. After the cores have been allocated, and assuming the phs initial configuration has been done before, we proceed with computing the [[pcm]] internal data. <>= procedure :: setup_cores => process_setup_cores <>= module subroutine process_setup_cores (process, dispatch_core, & helicity_selection, use_color_factors, has_beam_pol) class(process_t), intent(inout) :: process procedure(dispatch_core_proc) :: dispatch_core type(helicity_selection_t), intent(in), optional :: helicity_selection logical, intent(in), optional :: use_color_factors logical, intent(in), optional :: has_beam_pol end subroutine process_setup_cores <>= module subroutine process_setup_cores (process, dispatch_core, & helicity_selection, use_color_factors, has_beam_pol) class(process_t), intent(inout) :: process procedure(dispatch_core_proc) :: dispatch_core type(helicity_selection_t), intent(in), optional :: helicity_selection logical, intent(in), optional :: use_color_factors logical, intent(in), optional :: has_beam_pol integer :: i associate (pcm => process%pcm) call pcm%allocate_cores (process%config, process%core_entry) do i = 1, size (process%core_entry) call dispatch_core (process%core_entry(i)%core, & process%core_entry(i)%core_def, & process%config%model, & helicity_selection, & process%config%qcd, & use_color_factors, & has_beam_pol) call process%core_entry(i)%configure & (process%env%get_lib_ptr (), process%meta%id) if (process%core_entry(i)%core%uses_blha ()) then call pcm%setup_blha (process%core_entry(i)) end if end do end associate end subroutine process_setup_cores @ %def process_setup_cores <>= abstract interface subroutine dispatch_core_proc (core, core_def, model, & helicity_selection, qcd, use_color_factors, has_beam_pol) import class(prc_core_t), allocatable, intent(inout) :: core class(prc_core_def_t), intent(in) :: core_def class(model_data_t), intent(in), target, optional :: model type(helicity_selection_t), intent(in), optional :: helicity_selection type(qcd_t), intent(in), optional :: qcd logical, intent(in), optional :: use_color_factors logical, intent(in), optional :: has_beam_pol end subroutine dispatch_core_proc end interface @ %def dispatch_core_proc @ Use the [[pcm]] to initialize the BLHA interface for each core which requires it. <>= procedure :: prepare_blha_cores => process_prepare_blha_cores <>= module subroutine process_prepare_blha_cores (process) class(process_t), intent(inout), target :: process end subroutine process_prepare_blha_cores <>= module subroutine process_prepare_blha_cores (process) class(process_t), intent(inout), target :: process integer :: i associate (pcm => process%pcm) do i = 1, size (process%core_entry) associate (core_entry => process%core_entry(i)) if (core_entry%core%uses_blha ()) then pcm%uses_blha = .true. call pcm%prepare_blha_core (core_entry, process%config%model) end if end associate end do end associate end subroutine process_prepare_blha_cores @ %def process_prepare_blha_cores @ Create the BLHA interface data, using PCM for specific data, and write the BLHA contract file(s). We take various configuration data and copy them to the [[blha_master]] record, which then creates and writes the contracts. For assigning the QCD/EW coupling powers, we inspect the first process component only. The other parameters are taken as-is from the process environment variables. <>= procedure :: create_blha_interface => process_create_blha_interface <>= module subroutine process_create_blha_interface (process) class(process_t), intent(inout) :: process end subroutine process_create_blha_interface <>= module subroutine process_create_blha_interface (process) class(process_t), intent(inout) :: process integer :: alpha_power, alphas_power integer :: openloops_phs_tolerance, openloops_stability_log logical :: use_cms type(string_t) :: ew_scheme, correction_type type(string_t) :: openloops_extra_cmd, openloops_allowed_libs type(blha_master_t) :: blha_master integer, dimension(:,:), allocatable :: flv_born, flv_real if (process%pcm%uses_blha) then call collect_configuration_parameters (process%get_var_list_ptr ()) call process%component(1)%config%get_coupling_powers & (alpha_power, alphas_power) associate (pcm => process%pcm) call pcm%set_blha_methods (blha_master, process%get_var_list_ptr ()) call blha_master%set_ew_scheme (ew_scheme) call blha_master%allocate_config_files () call blha_master%set_correction_type (correction_type) call blha_master%setup_additional_features ( & openloops_phs_tolerance, & use_cms, & openloops_stability_log, & extra_cmd = openloops_extra_cmd, & allowed_libs = openloops_allowed_libs, & beam_structure = process%env%get_beam_structure ()) call pcm%get_blha_flv_states (process%core_entry, flv_born, flv_real) call blha_master%set_photon_characteristics (flv_born, process%config%n_in) call blha_master%generate (process%meta%id, & process%config%model, process%config%n_in, & alpha_power, alphas_power, & flv_born, flv_real) call blha_master%write_olp (process%meta%id) end associate end if contains subroutine collect_configuration_parameters (var_list) type(var_list_t), intent(in) :: var_list openloops_phs_tolerance = & var_list%get_ival (var_str ("openloops_phs_tolerance")) openloops_stability_log = & var_list%get_ival (var_str ("openloops_stability_log")) use_cms = & var_list%get_lval (var_str ("?openloops_use_cms")) ew_scheme = & var_list%get_sval (var_str ("$blha_ew_scheme")) correction_type = & var_list%get_sval (var_str ("$nlo_correction_type")) openloops_extra_cmd = & var_list%get_sval (var_str ("$openloops_extra_cmd")) openloops_allowed_libs = & var_list%get_sval (var_str ("$openloops_allowed_libs")) end subroutine collect_configuration_parameters end subroutine process_create_blha_interface @ %def process_create_blha_interface @ Initialize the process components, one by one. We require templates for the [[mci]] (integrator) and [[phs_config]] (phase-space) configuration data. The [[active]] flag is set if the component has an associated matrix element, so we can compute it. The case of no core is a unit-test case. The specifics depend on the algorithm and are delegated to the [[pcm]] process-component manager. The optional [[phs_config]] overrides a pre-generated config array (for unit test). <>= procedure :: init_components => process_init_components <>= module subroutine process_init_components (process, phs_config) class(process_t), intent(inout), target :: process class(phs_config_t), allocatable, intent(in), optional :: phs_config end subroutine process_init_components <>= module subroutine process_init_components (process, phs_config) class(process_t), intent(inout), target :: process class(phs_config_t), allocatable, intent(in), optional :: phs_config integer :: i, i_core class(prc_core_t), pointer :: core logical :: active associate (pcm => process%pcm) do i = 1, pcm%n_components i_core = pcm%get_i_core(i) if (i_core > 0) then core => process%get_core_ptr (i_core) active = core%has_matrix_element () else active = .true. end if select type (pcm => process%pcm) type is (pcm_nlo_t) if (pcm%use_real_partition .and. .not. pcm%use_real_singular) then if (pcm%component_type(i) == COMP_REAL_SING) then active = .false. end if end if end select if (present (phs_config)) then call pcm%init_component (process%component(i), & i, & active, & phs_config, & process%env, process%meta, process%config) else call pcm%init_component (process%component(i), & i, & active, & process%phs_entry(pcm%i_phs_config(i))%phs_config, & process%env, process%meta, process%config) end if end do end associate end subroutine process_init_components @ %def process_init_components @ If process components have turned out to be inactive, this has to be recorded in the [[meta]] block. Delegate to the [[pcm]]. <>= procedure :: record_inactive_components => process_record_inactive_components <>= module subroutine process_record_inactive_components (process) class(process_t), intent(inout) :: process end subroutine process_record_inactive_components <>= module subroutine process_record_inactive_components (process) class(process_t), intent(inout) :: process associate (pcm => process%pcm) call pcm%record_inactive_components (process%component, process%meta) end associate end subroutine process_record_inactive_components @ %def process_record_inactive_components @ Determine the process terms for each process component. <>= procedure :: setup_terms => process_setup_terms <>= module subroutine process_setup_terms (process, with_beams) class(process_t), intent(inout), target :: process logical, intent(in), optional :: with_beams end subroutine process_setup_terms <>= module subroutine process_setup_terms (process, with_beams) class(process_t), intent(inout), target :: process logical, intent(in), optional :: with_beams class(model_data_t), pointer :: model integer :: i, j, k, i_term integer, dimension(:), allocatable :: n_entry integer :: n_components, n_tot integer :: i_sub type(string_t) :: subtraction_method class(prc_core_t), pointer :: core => null () logical :: setup_subtraction_component, singular_real logical :: requires_spin_correlations integer :: nlo_type_to_fetch, n_emitters i_sub = 0 model => process%config%model n_components = process%meta%n_components allocate (n_entry (n_components), source = 0) do i = 1, n_components associate (component => process%component(i)) if (component%active) then n_entry(i) = 1 if (component%get_nlo_type () == NLO_REAL) then select type (pcm => process%pcm) type is (pcm_nlo_t) if (pcm%component_type(i) /= COMP_REAL_FIN) & n_entry(i) = n_entry(i) + pcm%region_data%get_n_phs () end select end if end if end associate end do n_tot = sum (n_entry) allocate (process%term (n_tot)) k = 0 if (process%is_nlo_calculation ()) then i_sub = process%component(1)%config%get_associated_subtraction () subtraction_method = process%component(i_sub)%config%get_me_method () if (debug_on) call msg_debug2 & (D_PROCESS_INTEGRATION, "process_setup_terms: ", subtraction_method) end if do i = 1, n_components associate (component => process%component(i)) if (.not. component%active) cycle allocate (component%i_term (n_entry(i))) do j = 1, n_entry(i) select type (pcm => process%pcm) type is (pcm_nlo_t) singular_real = component%get_nlo_type () == NLO_REAL & .and. pcm%component_type(i) /= COMP_REAL_FIN class default singular_real = .false. end select setup_subtraction_component = singular_real .and. j == n_entry(i) i_term = k + j component%i_term(j) = i_term if (singular_real) then process%term(i_term)%i_sub = k + n_entry(i) else process%term(i_term)%i_sub = 0 end if if (setup_subtraction_component) then select type (pcm => process%pcm) class is (pcm_nlo_t) process%term(i_term)%i_core = pcm%i_core(pcm%i_sub) end select else process%term(i_term)%i_core = process%pcm%get_i_core(i) end if if (process%term(i_term)%i_core == 0) then call msg_bug ("Process '" // char (process%get_id ()) & // "': core not found!") end if core => process%get_core_term (i_term) if (i_sub > 0) then select type (pcm => process%pcm) type is (pcm_nlo_t) requires_spin_correlations = & pcm%region_data%requires_spin_correlations () n_emitters = pcm%region_data%get_n_emitters_sc () class default requires_spin_correlations = .false. n_emitters = 0 end select if (requires_spin_correlations) then call process%term(i_term)%init ( & i_term, i, j, core, model, & nlo_type = component%config%get_nlo_type (), & use_beam_pol = with_beams, & subtraction_method = subtraction_method, & has_pdfs = process%pcm%has_pdfs, & n_emitters = n_emitters) else call process%term(i_term)%init ( & i_term, i, j, core, model, & nlo_type = component%config%get_nlo_type (), & use_beam_pol = with_beams, & subtraction_method = subtraction_method, & has_pdfs = process%pcm%has_pdfs) end if else call process%term(i_term)%init ( & i_term, i, j, core, model, & nlo_type = component%config%get_nlo_type (), & use_beam_pol = with_beams, & has_pdfs = process%pcm%has_pdfs) end if end do end associate k = k + n_entry(i) end do process%config%n_terms = n_tot end subroutine process_setup_terms @ %def process_setup_terms @ Initialize the beam setup. This is the trivial version where the incoming state of the matrix element coincides with the initial state of the process. For a scattering process, we need the c.m. energy, all other variables are set to their default values (no polarization, lab frame and c.m.\ frame coincide, etc.) We assume that all components consistently describe a scattering process, i.e., two incoming particles. Note: The current layout of the [[beam_data_t]] record requires that the flavor for each beam is unique. For processes with multiple flavors in the initial state, one has to set up beams explicitly. This restriction could be removed by extending the code in the [[beams]] module. <>= procedure :: setup_beams_sqrts => process_setup_beams_sqrts <>= module subroutine process_setup_beams_sqrts & (process, sqrts, beam_structure, i_core) class(process_t), intent(inout) :: process real(default), intent(in) :: sqrts type(beam_structure_t), intent(in), optional :: beam_structure integer, intent(in), optional :: i_core end subroutine process_setup_beams_sqrts <>= module subroutine process_setup_beams_sqrts & (process, sqrts, beam_structure, i_core) class(process_t), intent(inout) :: process real(default), intent(in) :: sqrts type(beam_structure_t), intent(in), optional :: beam_structure integer, intent(in), optional :: i_core type(pdg_array_t), dimension(:,:), allocatable :: pdg_in integer, dimension(2) :: pdg_scattering type(flavor_t), dimension(2) :: flv_in integer :: i, i0, ic allocate (pdg_in (2, process%meta%n_components)) i0 = 0 do i = 1, process%meta%n_components if (process%component(i)%active) then if (present (i_core)) then ic = i_core else ic = process%pcm%get_i_core (i) end if associate (core => process%core_entry(ic)%core) pdg_in(:,i) = core%data%get_pdg_in () end associate if (i0 == 0) i0 = i end if end do do i = 1, process%meta%n_components if (.not. process%component(i)%active) then pdg_in(:,i) = pdg_in(:,i0) end if end do if (all (pdg_in%get_length () == 1) .and. & all (pdg_in(1,:) == pdg_in(1,i0)) .and. & all (pdg_in(2,:) == pdg_in(2,i0))) then pdg_scattering(:) = pdg_in(:,i0)%get (1) call flv_in%init (pdg_scattering, process%config%model) call process%beam_config%init_scattering (flv_in, sqrts, beam_structure) else call msg_fatal ("Setting up process '" // char (process%meta%id) // "':", & [var_str (" --------------------------------------------"), & var_str ("Inconsistent initial state. This happens if either "), & var_str ("several processes with non-matching initial states "), & var_str ("have been added, or for a single process with an "), & var_str ("initial state flavor sum. In that case, please set beams "), & var_str ("explicitly [singling out a flavor / structure function.]")]) end if end subroutine process_setup_beams_sqrts @ %def process_setup_beams_sqrts @ This is the version that applies to decay processes. The energy is the particle mass, hence no extra argument. <>= procedure :: setup_beams_decay => process_setup_beams_decay <>= module subroutine process_setup_beams_decay & (process, rest_frame, beam_structure, i_core) class(process_t), intent(inout), target :: process logical, intent(in), optional :: rest_frame type(beam_structure_t), intent(in), optional :: beam_structure integer, intent(in), optional :: i_core end subroutine process_setup_beams_decay <>= module subroutine process_setup_beams_decay & (process, rest_frame, beam_structure, i_core) class(process_t), intent(inout), target :: process logical, intent(in), optional :: rest_frame type(beam_structure_t), intent(in), optional :: beam_structure integer, intent(in), optional :: i_core type(pdg_array_t), dimension(:,:), allocatable :: pdg_in integer, dimension(1) :: pdg_decay type(flavor_t), dimension(1) :: flv_in integer :: i, i0, ic allocate (pdg_in (1, process%meta%n_components)) i0 = 0 do i = 1, process%meta%n_components if (process%component(i)%active) then if (present (i_core)) then ic = i_core else ic = process%pcm%get_i_core (i) end if associate (core => process%core_entry(ic)%core) pdg_in(:,i) = core%data%get_pdg_in () end associate if (i0 == 0) i0 = i end if end do do i = 1, process%meta%n_components if (.not. process%component(i)%active) then pdg_in(:,i) = pdg_in(:,i0) end if end do if (all (pdg_in%get_length () == 1) & .and. all (pdg_in(1,:) == pdg_in(1,i0))) then pdg_decay(:) = pdg_in(:,i0)%get (1) call flv_in%init (pdg_decay, process%config%model) call process%beam_config%init_decay (flv_in, rest_frame, beam_structure) else call msg_fatal ("Setting up decay '" & // char (process%meta%id) // "': decaying particle not unique") end if end subroutine process_setup_beams_decay @ %def process_setup_beams_decay @ We have to make sure that the masses of the various flavors in a given position in the particle string coincide. <>= procedure :: check_masses => process_check_masses <>= module subroutine process_check_masses (process) class(process_t), intent(in) :: process end subroutine process_check_masses <>= module subroutine process_check_masses (process) class(process_t), intent(in) :: process type(flavor_t), dimension(:), allocatable :: flv real(default), dimension(:), allocatable :: mass integer :: i, j integer :: i_component class(prc_core_t), pointer :: core do i = 1, process%get_n_terms () i_component = process%term(i)%i_component if (.not. process%component(i_component)%active) cycle core => process%get_core_term (i) associate (data => core%data) allocate (flv (data%n_flv), mass (data%n_flv)) do j = 1, data%n_in + data%n_out call flv%init (data%flv_state(j,:), process%config%model) mass = flv%get_mass () if (any (.not. nearly_equal(mass, mass(1)))) then call msg_fatal ("Process '" // char (process%meta%id) // "': " & // "mass values in flavor combination do not coincide. ") end if end do deallocate (flv, mass) end associate end do end subroutine process_check_masses @ %def process_check_masses @ Set up index mapping for [[region_data]] for singular regions equivalent w.r.t. their amplitudes. Has to be called after [[region_data]] AND the [[core]] are fully set up. For processes with structure function, subprocesses which lead to the same amplitude for the hard interaction can differ if structure functions are applied. In this case we remap flavor structures to themselves if the eqvivalent hard interaction flavor structure has no identical initial state. <>= procedure :: optimize_nlo_singular_regions => & process_optimize_nlo_singular_regions <>= module subroutine process_optimize_nlo_singular_regions (process) class(process_t), intent(inout) :: process end subroutine process_optimize_nlo_singular_regions <>= module subroutine process_optimize_nlo_singular_regions (process) class(process_t), intent(inout) :: process class(prc_core_t), pointer :: core, core_sub integer, dimension(:), allocatable :: eqv_flv_index_born integer, dimension(:), allocatable :: eqv_flv_index_real integer, dimension(:,:), allocatable :: flv_born, flv_real integer :: i_flv, i_flv2, n_in, i integer :: i_component, i_core, i_core_sub logical :: fetched_born, fetched_real logical :: optimize fetched_born = .false.; fetched_real = .false. select type (pcm => process%pcm) type is (pcm_nlo_t) optimize = pcm%settings%reuse_amplitudes_fks if (optimize) then do i_component = 1, pcm%n_components i_core = pcm%get_i_core(i_component) core => process%get_core_ptr (i_core) if (.not. core%data_known) cycle associate (data => core%data) if (pcm%nlo_type_core(i_core) == NLO_REAL .and. & .not. pcm%component_type(i_component) == COMP_SUB) then if (allocated (core%data%eqv_flv_index)) then eqv_flv_index_real = core%get_equivalent_flv_index () fetched_real = .true. end if i_core_sub = pcm%get_i_core (pcm%i_sub) core_sub => process%get_core_ptr (i_core_sub) if (allocated (core_sub%data%eqv_flv_index)) then eqv_flv_index_born = core_sub%get_equivalent_flv_index () fetched_born = .true. end if if (fetched_born .and. fetched_real) exit end if end associate end do if (.not. fetched_born .or. .not. fetched_real) then call msg_warning('Failed to fetch flavor equivalence indices. & &Disabling singular region optimization') optimize = .false. eqv_flv_index_born = [(i, i = 1, pcm%region_data%n_flv_born)] eqv_flv_index_real = [(i, i = 1, pcm%region_data%n_flv_real)] end if if (optimize .and. pcm%has_pdfs) then flv_born = pcm%region_data%get_flv_states_born () flv_real = pcm%region_data%get_flv_states_real () n_in = pcm%region_data%n_in do i_flv = 1, size (eqv_flv_index_born) do i_flv2 = 1, i_flv if (any (flv_born(1:n_in, eqv_flv_index_born(i_flv)) /= & flv_born(1:n_in, i_flv))) then eqv_flv_index_born(i_flv) = i_flv exit end if end do end do do i_flv = 1, size (eqv_flv_index_real) do i_flv2 = 1, i_flv if (any (flv_real(1:n_in, eqv_flv_index_real(i_flv)) /= & flv_real(1:n_in, i_flv))) then eqv_flv_index_real(i_flv) = i_flv exit end if end do end do end if else eqv_flv_index_born = [(i, i = 1, pcm%region_data%n_flv_born)] eqv_flv_index_real = [(i, i = 1, pcm%region_data%n_flv_real)] end if pcm%region_data%eqv_flv_index_born = eqv_flv_index_born pcm%region_data%eqv_flv_index_real = eqv_flv_index_real call pcm%region_data%find_eqv_regions (optimize) end select end subroutine process_optimize_nlo_singular_regions @ %def process_optimize_nlo_singular_regions @ For some structure functions we need to get the list of initial state flavors. This is a two-dimensional array. The first index is the beam index, the second index is the component index. Each array element is itself a PDG array object, which consists of the list of incoming PDG values for this beam and component. <>= procedure :: get_pdg_in => process_get_pdg_in <>= module subroutine process_get_pdg_in (process, pdg_in) class(process_t), intent(in), target :: process type(pdg_array_t), dimension(:,:), allocatable, intent(out) :: pdg_in end subroutine process_get_pdg_in <>= module subroutine process_get_pdg_in (process, pdg_in) class(process_t), intent(in), target :: process type(pdg_array_t), dimension(:,:), allocatable, intent(out) :: pdg_in integer :: i, i_core allocate (pdg_in (process%config%n_in, process%meta%n_components)) do i = 1, process%meta%n_components if (process%component(i)%active) then i_core = process%pcm%get_i_core (i) associate (core => process%core_entry(i_core)%core) pdg_in(:,i) = core%data%get_pdg_in () end associate end if end do end subroutine process_get_pdg_in @ %def process_get_pdg_in @ The phase-space configuration object, in case we need it separately. <>= procedure :: get_phs_config => process_get_phs_config <>= module function process_get_phs_config & (process, i_component) result (phs_config) class(phs_config_t), pointer :: phs_config class(process_t), intent(in), target :: process integer, intent(in) :: i_component end function process_get_phs_config <>= module function process_get_phs_config & (process, i_component) result (phs_config) class(phs_config_t), pointer :: phs_config class(process_t), intent(in), target :: process integer, intent(in) :: i_component if (allocated (process%component)) then phs_config => process%component(i_component)%phs_config else phs_config => null () end if end function process_get_phs_config @ %def process_get_phs_config @ The resonance history set can be extracted from the phase-space configuration. However, this is only possible if the default phase-space method (wood) has been chosen. If [[include_trivial]] is set, we include the resonance history with no resonances in the set. <>= procedure :: extract_resonance_history_set & => process_extract_resonance_history_set <>= module subroutine process_extract_resonance_history_set & (process, res_set, include_trivial, i_component) class(process_t), intent(in), target :: process type(resonance_history_set_t), intent(out) :: res_set logical, intent(in), optional :: include_trivial integer, intent(in), optional :: i_component end subroutine process_extract_resonance_history_set <>= module subroutine process_extract_resonance_history_set & (process, res_set, include_trivial, i_component) class(process_t), intent(in), target :: process type(resonance_history_set_t), intent(out) :: res_set logical, intent(in), optional :: include_trivial integer, intent(in), optional :: i_component integer :: i i = 1; if (present (i_component)) i = i_component select type (phs_config => process%get_phs_config (i)) class is (phs_wood_config_t) call phs_config%extract_resonance_history_set (res_set, include_trivial) class default call msg_error ("process '" // char (process%get_id ()) & // "': extract resonance histories: phase-space method must be & &'wood'. No resonances can be determined.") end select end subroutine process_extract_resonance_history_set @ %def process_extract_resonance_history_set @ Initialize from a complete beam setup. If the beam setup does not apply directly to the process, choose a fallback option as a straight scattering or decay process. <>= procedure :: setup_beams_beam_structure => process_setup_beams_beam_structure <>= module subroutine process_setup_beams_beam_structure & (process, beam_structure, sqrts, decay_rest_frame) class(process_t), intent(inout) :: process type(beam_structure_t), intent(in) :: beam_structure real(default), intent(in) :: sqrts logical, intent(in), optional :: decay_rest_frame end subroutine process_setup_beams_beam_structure <>= module subroutine process_setup_beams_beam_structure & (process, beam_structure, sqrts, decay_rest_frame) class(process_t), intent(inout) :: process type(beam_structure_t), intent(in) :: beam_structure real(default), intent(in) :: sqrts logical, intent(in), optional :: decay_rest_frame integer :: n_in logical :: applies n_in = process%get_n_in () call beam_structure%check_against_n_in (process%get_n_in (), applies) if (applies) then call process%beam_config%init_beam_structure & (beam_structure, sqrts, process%get_model_ptr (), decay_rest_frame) else if (n_in == 2) then call process%setup_beams_sqrts (sqrts, beam_structure) else call process%setup_beams_decay (decay_rest_frame, beam_structure) end if end subroutine process_setup_beams_beam_structure @ %def process_setup_beams_beam_structure @ Notify the user about beam setup. <>= procedure :: beams_startup_message => process_beams_startup_message <>= module subroutine process_beams_startup_message & (process, unit, beam_structure) class(process_t), intent(in) :: process integer, intent(in), optional :: unit type(beam_structure_t), intent(in), optional :: beam_structure end subroutine process_beams_startup_message <>= module subroutine process_beams_startup_message & (process, unit, beam_structure) class(process_t), intent(in) :: process integer, intent(in), optional :: unit type(beam_structure_t), intent(in), optional :: beam_structure call process%beam_config%startup_message (unit, beam_structure) end subroutine process_beams_startup_message @ %def process_beams_startup_message @ Initialize phase-space configuration by reading out the environment variables. We return the rebuild flags and store parameters in the blocks [[phs_par]] and [[mapping_defs]]. The phase-space configuration object(s) are allocated by [[pcm]]. <>= procedure :: init_phs_config => process_init_phs_config <>= module subroutine process_init_phs_config (process) class(process_t), intent(inout) :: process end subroutine process_init_phs_config <>= module subroutine process_init_phs_config (process) class(process_t), intent(inout) :: process type(var_list_t), pointer :: var_list type(phs_parameters_t) :: phs_par type(mapping_defaults_t) :: mapping_defs var_list => process%env%get_var_list_ptr () phs_par%m_threshold_s = & var_list%get_rval (var_str ("phs_threshold_s")) phs_par%m_threshold_t = & var_list%get_rval (var_str ("phs_threshold_t")) phs_par%off_shell = & var_list%get_ival (var_str ("phs_off_shell")) phs_par%keep_nonresonant = & var_list%get_lval (var_str ("?phs_keep_nonresonant")) phs_par%t_channel = & var_list%get_ival (var_str ("phs_t_channel")) mapping_defs%energy_scale = & var_list%get_rval (var_str ("phs_e_scale")) mapping_defs%invariant_mass_scale = & var_list%get_rval (var_str ("phs_m_scale")) mapping_defs%momentum_transfer_scale = & var_list%get_rval (var_str ("phs_q_scale")) mapping_defs%step_mapping = & var_list%get_lval (var_str ("?phs_step_mapping")) mapping_defs%step_mapping_exp = & var_list%get_lval (var_str ("?phs_step_mapping_exp")) mapping_defs%enable_s_mapping = & var_list%get_lval (var_str ("?phs_s_mapping")) associate (pcm => process%pcm) call pcm%init_phs_config (process%phs_entry, & process%meta, process%env, phs_par, mapping_defs) end associate end subroutine process_init_phs_config @ %def process_init_phs_config @ We complete the kinematics configuration after the beam setup, but before we configure the chain of structure functions. The reason is that we need the total energy [[sqrts]] for the kinematics, but the structure-function setup requires the number of channels, which depends on the kinematics configuration. For instance, the kinematics module may return the need for parameterizing an s-channel resonance. <>= procedure :: configure_phs => process_configure_phs <>= module subroutine process_configure_phs (process, rebuild, & ignore_mismatch, combined_integration, subdir) class(process_t), intent(inout) :: process logical, intent(in), optional :: rebuild logical, intent(in), optional :: ignore_mismatch logical, intent(in), optional :: combined_integration type(string_t), intent(in), optional :: subdir end subroutine process_configure_phs <>= module subroutine process_configure_phs (process, rebuild, & ignore_mismatch, combined_integration, subdir) class(process_t), intent(inout) :: process logical, intent(in), optional :: rebuild logical, intent(in), optional :: ignore_mismatch logical, intent(in), optional :: combined_integration type(string_t), intent(in), optional :: subdir real(default) :: sqrts integer :: i, i_born, nlo_type class(phs_config_t), pointer :: phs_config_born sqrts = process%get_sqrts () do i = 1, process%meta%n_components associate (component => process%component(i)) if (component%active) then select type (pcm => process%pcm) type is (pcm_default_t) call component%configure_phs (sqrts, process%beam_config, & rebuild, ignore_mismatch, subdir) class is (pcm_nlo_t) nlo_type = component%config%get_nlo_type () select case (nlo_type) case (BORN, NLO_VIRTUAL, NLO_SUBTRACTION) call component%configure_phs (sqrts, process%beam_config, & rebuild, ignore_mismatch, subdir) call check_and_extend_phs (component) case (NLO_REAL, NLO_MISMATCH, NLO_DGLAP) i_born = component%config%get_associated_born () if (pcm%component_type(i) /= COMP_REAL_FIN) & call check_and_extend_phs (component) call process%component(i_born)%get_phs_config & (phs_config_born) select type (config => component%phs_config) type is (phs_fks_config_t) select type (phs_config_born) type is (phs_wood_config_t) config%md5sum_born_config = & phs_config_born%md5sum_phs_config call config%set_born_config (phs_config_born) call config%set_mode (component%config%get_nlo_type ()) end select end select call component%configure_phs (sqrts, & process%beam_config, rebuild, ignore_mismatch, subdir) end select class default call msg_bug ("process_configure_phs: unsupported PCM type") end select end if end associate end do contains subroutine check_and_extend_phs (component) type(process_component_t), intent(inout) :: component if (combined_integration) then select type (phs_config => component%phs_config) class is (phs_wood_config_t) phs_config%is_combined_integration = .true. call phs_config%increase_n_par () end select end if end subroutine check_and_extend_phs end subroutine process_configure_phs @ %def process_configure_phs @ <>= procedure :: print_phs_startup_message => process_print_phs_startup_message <>= module subroutine process_print_phs_startup_message (process) class(process_t), intent(in) :: process end subroutine process_print_phs_startup_message <>= module subroutine process_print_phs_startup_message (process) class(process_t), intent(in) :: process integer :: i_component do i_component = 1, process%meta%n_components associate (component => process%component(i_component)) if (component%active) then call component%phs_config%startup_message () end if end associate end do end subroutine process_print_phs_startup_message @ %def process_print_phs_startup_message @ Insert the structure-function configuration data. First allocate the storage, then insert data one by one. The third procedure declares a mapping (of the MC input parameters) for a specific channel and structure-function combination. We take the number of channels from the corresponding entry in the [[config_data]] section. Otherwise, these a simple wrapper routines. The extra level in the call tree may allow for simple addressing of multiple concurrent beam configurations, not implemented currently. If we do not want structure functions, we simply do not call those procedures. <>= procedure :: init_sf_chain => process_init_sf_chain generic :: set_sf_channel => set_sf_channel_single procedure :: set_sf_channel_single => process_set_sf_channel generic :: set_sf_channel => set_sf_channel_array procedure :: set_sf_channel_array => process_set_sf_channel_array <>= module subroutine process_init_sf_chain (process, sf_config, sf_trace_file) class(process_t), intent(inout) :: process type(sf_config_t), dimension(:), intent(in) :: sf_config type(string_t), intent(in), optional :: sf_trace_file end subroutine process_init_sf_chain module subroutine process_set_sf_channel (process, c, sf_channel) class(process_t), intent(inout) :: process integer, intent(in) :: c type(sf_channel_t), intent(in) :: sf_channel end subroutine process_set_sf_channel module subroutine process_set_sf_channel_array (process, sf_channel) class(process_t), intent(inout) :: process type(sf_channel_t), dimension(:), intent(in) :: sf_channel end subroutine process_set_sf_channel_array <>= module subroutine process_init_sf_chain (process, sf_config, sf_trace_file) class(process_t), intent(inout) :: process type(sf_config_t), dimension(:), intent(in) :: sf_config type(string_t), intent(in), optional :: sf_trace_file type(string_t) :: file if (present (sf_trace_file)) then if (sf_trace_file /= "") then file = sf_trace_file else file = process%get_id () // "_sftrace.dat" end if call process%beam_config%init_sf_chain (sf_config, file) else call process%beam_config%init_sf_chain (sf_config) end if end subroutine process_init_sf_chain module subroutine process_set_sf_channel (process, c, sf_channel) class(process_t), intent(inout) :: process integer, intent(in) :: c type(sf_channel_t), intent(in) :: sf_channel call process%beam_config%set_sf_channel (c, sf_channel) end subroutine process_set_sf_channel module subroutine process_set_sf_channel_array (process, sf_channel) class(process_t), intent(inout) :: process type(sf_channel_t), dimension(:), intent(in) :: sf_channel integer :: c call process%beam_config%allocate_sf_channels (size (sf_channel)) do c = 1, size (sf_channel) call process%beam_config%set_sf_channel (c, sf_channel(c)) end do end subroutine process_set_sf_channel_array @ %def process_init_sf_chain @ %def process_set_sf_channel @ Notify about the structure-function setup. <>= procedure :: sf_startup_message => process_sf_startup_message <>= module subroutine process_sf_startup_message (process, sf_string, unit) class(process_t), intent(in) :: process type(string_t), intent(in) :: sf_string integer, intent(in), optional :: unit end subroutine process_sf_startup_message <>= module subroutine process_sf_startup_message (process, sf_string, unit) class(process_t), intent(in) :: process type(string_t), intent(in) :: sf_string integer, intent(in), optional :: unit call process%beam_config%sf_startup_message (sf_string, unit) end subroutine process_sf_startup_message @ %def process_sf_startup_message @ As soon as both the kinematics configuration and the structure-function setup are complete, we match parameterizations (channels) for both. The matching entries are (re)set in the [[component]] phase-space configuration, while the structure-function configuration is left intact. <>= procedure :: collect_channels => process_collect_channels <>= module subroutine process_collect_channels (process, coll) class(process_t), intent(inout) :: process type(phs_channel_collection_t), intent(inout) :: coll end subroutine process_collect_channels <>= module subroutine process_collect_channels (process, coll) class(process_t), intent(inout) :: process type(phs_channel_collection_t), intent(inout) :: coll integer :: i do i = 1, process%meta%n_components associate (component => process%component(i)) if (component%active) & call component%collect_channels (coll) end associate end do end subroutine process_collect_channels @ %def process_collect_channels @ Independently, we should be able to check if any component does not contain phase-space parameters. Such a process can only be integrated if there are structure functions. <>= procedure :: contains_trivial_component => process_contains_trivial_component <>= module function process_contains_trivial_component (process) result (flag) class(process_t), intent(in) :: process logical :: flag end function process_contains_trivial_component <>= module function process_contains_trivial_component (process) result (flag) class(process_t), intent(in) :: process logical :: flag integer :: i flag = .true. do i = 1, process%meta%n_components associate (component => process%component(i)) if (component%active) then if (component%get_n_phs_par () == 0) return end if end associate end do flag = .false. end function process_contains_trivial_component @ %def process_contains_trivial_component @ <>= procedure :: get_master_component => process_get_master_component <>= module function process_get_master_component & (process, i_mci) result (i_component) integer :: i_component class(process_t), intent(in) :: process integer, intent(in) :: i_mci end function process_get_master_component <>= module function process_get_master_component & (process, i_mci) result (i_component) integer :: i_component class(process_t), intent(in) :: process integer, intent(in) :: i_mci integer :: i i_component = 0 do i = 1, size (process%component) if (process%component(i)%i_mci == i_mci) then i_component = i return end if end do end function process_get_master_component @ %def process_get_master_component @ Determine the MC parameter set structure and the MCI configuration for each process component. We need data from the structure-function and phase-space setup, so those should be complete before this is called. We also make a random-number generator instance for each MCI group. <>= procedure :: setup_mci => process_setup_mci <>= module subroutine process_setup_mci (process, dispatch_mci) class(process_t), intent(inout) :: process procedure(dispatch_mci_proc) :: dispatch_mci end subroutine process_setup_mci <>= module subroutine process_setup_mci (process, dispatch_mci) class(process_t), intent(inout) :: process procedure(dispatch_mci_proc) :: dispatch_mci class(mci_t), allocatable :: mci_template integer :: i, i_mci if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_setup_mci") associate (pcm => process%pcm) call pcm%call_dispatch_mci (dispatch_mci, & process%get_var_list_ptr (), process%meta%id, mci_template) call pcm%setup_mci (process%mci_entry) process%config%n_mci = pcm%n_mci process%component(:)%i_mci = pcm%i_mci(:) do i = 1, pcm%n_components i_mci = process%pcm%i_mci(i) if (i_mci > 0) then associate (component => process%component(i), & mci_entry => process%mci_entry(i_mci)) call mci_entry%configure (mci_template, & process%meta%type, & i_mci, i, component, process%beam_config%n_sfpar, & process%rng_factory) call mci_entry%set_parameters (process%get_var_list_ptr ()) end associate end if end do end associate end subroutine process_setup_mci @ %def process_setup_mci @ Set cuts. This is a parse node, namely the right-hand side of the [[cut]] assignment. When creating an instance, we compile this into an evaluation tree. The parse node may be null. <>= procedure :: set_cuts => process_set_cuts <>= module subroutine process_set_cuts (process, ef_cuts) class(process_t), intent(inout) :: process class(expr_factory_t), intent(in) :: ef_cuts end subroutine process_set_cuts <>= module subroutine process_set_cuts (process, ef_cuts) class(process_t), intent(inout) :: process class(expr_factory_t), intent(in) :: ef_cuts allocate (process%config%ef_cuts, source = ef_cuts) end subroutine process_set_cuts @ %def process_set_cuts @ Analogously for the other expressions. <>= procedure :: set_scale => process_set_scale procedure :: set_fac_scale => process_set_fac_scale procedure :: set_ren_scale => process_set_ren_scale procedure :: set_weight => process_set_weight <>= module subroutine process_set_scale (process, ef_scale) class(process_t), intent(inout) :: process class(expr_factory_t), intent(in) :: ef_scale end subroutine process_set_scale module subroutine process_set_weight (process, ef_weight) class(process_t), intent(inout) :: process class(expr_factory_t), intent(in) :: ef_weight end subroutine process_set_weight module subroutine process_set_fac_scale (process, ef_fac_scale) class(process_t), intent(inout) :: process class(expr_factory_t), intent(in) :: ef_fac_scale end subroutine process_set_fac_scale module subroutine process_set_ren_scale (process, ef_ren_scale) class(process_t), intent(inout) :: process class(expr_factory_t), intent(in) :: ef_ren_scale end subroutine process_set_ren_scale <>= module subroutine process_set_scale (process, ef_scale) class(process_t), intent(inout) :: process class(expr_factory_t), intent(in) :: ef_scale allocate (process%config%ef_scale, source = ef_scale) end subroutine process_set_scale module subroutine process_set_fac_scale (process, ef_fac_scale) class(process_t), intent(inout) :: process class(expr_factory_t), intent(in) :: ef_fac_scale allocate (process%config%ef_fac_scale, source = ef_fac_scale) end subroutine process_set_fac_scale module subroutine process_set_ren_scale (process, ef_ren_scale) class(process_t), intent(inout) :: process class(expr_factory_t), intent(in) :: ef_ren_scale allocate (process%config%ef_ren_scale, source = ef_ren_scale) end subroutine process_set_ren_scale module subroutine process_set_weight (process, ef_weight) class(process_t), intent(inout) :: process class(expr_factory_t), intent(in) :: ef_weight allocate (process%config%ef_weight, source = ef_weight) end subroutine process_set_weight @ %def process_set_scale @ %def process_set_fac_scale @ %def process_set_ren_scale @ %def process_set_weight @ \subsubsection{MD5 sum} The MD5 sum of the process object should reflect the state completely, including integration results. It is used for checking the integrity of event files. This global checksum includes checksums for the various parts. In particular, the MCI object receives a checksum that includes the configuration of all configuration parts relevant for an individual integration. This checksum is used for checking the integrity of integration grids. We do not need MD5 sums for the process terms, since these are generated from the component definitions. <>= procedure :: compute_md5sum => process_compute_md5sum <>= module subroutine process_compute_md5sum (process) class(process_t), intent(inout) :: process end subroutine process_compute_md5sum <>= module subroutine process_compute_md5sum (process) class(process_t), intent(inout) :: process integer :: i call process%config%compute_md5sum () do i = 1, process%config%n_components associate (component => process%component(i)) if (component%active) then call component%compute_md5sum () end if end associate end do call process%beam_config%compute_md5sum () do i = 1, process%config%n_mci call process%mci_entry(i)%compute_md5sum & (process%config, process%component, process%beam_config) end do end subroutine process_compute_md5sum @ %def process_compute_md5sum @ <>= procedure :: sampler_test => process_sampler_test <>= module subroutine process_sampler_test (process, sampler, n_calls, i_mci) class(process_t), intent(inout) :: process class(mci_sampler_t), intent(inout) :: sampler integer, intent(in) :: n_calls, i_mci end subroutine process_sampler_test <>= module subroutine process_sampler_test (process, sampler, n_calls, i_mci) class(process_t), intent(inout) :: process class(mci_sampler_t), intent(inout) :: sampler integer, intent(in) :: n_calls, i_mci call process%mci_entry(i_mci)%sampler_test (sampler, n_calls) end subroutine process_sampler_test @ %def process_sampler_test @ The finalizer should be called after all integration passes have been completed. It will, for instance, write a summary of the integration results. [[integrate_dummy]] does a ``dummy'' integration in the sense that nothing is done but just empty integration results appended. <>= procedure :: final_integration => process_final_integration procedure :: integrate_dummy => process_integrate_dummy <>= module subroutine process_final_integration (process, i_mci) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci end subroutine process_final_integration module subroutine process_integrate_dummy (process) class(process_t), intent(inout) :: process end subroutine process_integrate_dummy <>= module subroutine process_final_integration (process, i_mci) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci call process%mci_entry(i_mci)%final_integration () end subroutine process_final_integration module subroutine process_integrate_dummy (process) class(process_t), intent(inout) :: process type(integration_results_t) :: results integer :: u_log u_log = logfile_unit () call results%init (process%meta%type) call results%display_init (screen = .true., unit = u_log) call results%new_pass () call results%record (1, 0, 0._default, 0._default, 0._default) call results%display_final () end subroutine process_integrate_dummy @ %def process_final_integration @ %def process_integrate_dummy @ <>= procedure :: integrate => process_integrate <>= module subroutine process_integrate (process, i_mci, mci_work, & mci_sampler, n_it, n_calls, adapt_grids, adapt_weights, final, & pacify, nlo_type) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(mci_work_t), intent(inout) :: mci_work class(mci_sampler_t), intent(inout) :: mci_sampler integer, intent(in) :: n_it, n_calls logical, intent(in), optional :: adapt_grids, adapt_weights logical, intent(in), optional :: final logical, intent(in), optional :: pacify integer, intent(in), optional :: nlo_type end subroutine process_integrate <>= module subroutine process_integrate (process, i_mci, mci_work, & mci_sampler, n_it, n_calls, adapt_grids, adapt_weights, final, & pacify, nlo_type) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(mci_work_t), intent(inout) :: mci_work class(mci_sampler_t), intent(inout) :: mci_sampler integer, intent(in) :: n_it, n_calls logical, intent(in), optional :: adapt_grids, adapt_weights logical, intent(in), optional :: final logical, intent(in), optional :: pacify integer, intent(in), optional :: nlo_type associate (mci_entry => process%mci_entry(i_mci)) call mci_entry%integrate (mci_work%mci, mci_sampler, n_it, n_calls, & adapt_grids, adapt_weights, final, pacify, & nlo_type = nlo_type) call mci_entry%results%display_pass (pacify) end associate end subroutine process_integrate @ %def process_integrate @ <>= procedure :: generate_weighted_event => process_generate_weighted_event <>= module subroutine process_generate_weighted_event (process, i_mci, & mci_work, mci_sampler, keep_failed_events) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(mci_work_t), intent(inout) :: mci_work class(mci_sampler_t), intent(inout) :: mci_sampler logical, intent(in) :: keep_failed_events end subroutine process_generate_weighted_event <>= module subroutine process_generate_weighted_event (process, i_mci, & mci_work, mci_sampler, keep_failed_events) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(mci_work_t), intent(inout) :: mci_work class(mci_sampler_t), intent(inout) :: mci_sampler logical, intent(in) :: keep_failed_events associate (mci_entry => process%mci_entry(i_mci)) call mci_entry%generate_weighted_event (mci_work%mci, & mci_sampler, keep_failed_events) end associate end subroutine process_generate_weighted_event @ %def process_generate_weighted_event <>= procedure :: generate_unweighted_event => process_generate_unweighted_event <>= module subroutine process_generate_unweighted_event (process, i_mci, & mci_work, mci_sampler) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(mci_work_t), intent(inout) :: mci_work class(mci_sampler_t), intent(inout) :: mci_sampler end subroutine process_generate_unweighted_event <>= module subroutine process_generate_unweighted_event (process, i_mci, & mci_work, mci_sampler) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(mci_work_t), intent(inout) :: mci_work class(mci_sampler_t), intent(inout) :: mci_sampler associate (mci_entry => process%mci_entry(i_mci)) call mci_entry%generate_unweighted_event & (mci_work%mci, mci_sampler) end associate end subroutine process_generate_unweighted_event @ %def process_generate_unweighted_event @ Display the final results for the sum of all components. This is useful, obviously, only if there is more than one component and not if a combined integration of all components together has been performed. <>= procedure :: display_summed_results => process_display_summed_results <>= module subroutine process_display_summed_results (process, pacify) class(process_t), intent(inout) :: process logical, intent(in) :: pacify end subroutine process_display_summed_results <>= module subroutine process_display_summed_results (process, pacify) class(process_t), intent(inout) :: process logical, intent(in) :: pacify type(integration_results_t) :: results integer :: u_log u_log = logfile_unit () call results%init (process%meta%type) call results%display_init (screen = .true., unit = u_log) call results%new_pass () call results%record (1, 0, & process%get_integral (), & process%get_error (), & process%get_efficiency (), suppress = pacify) select type (pcm => process%pcm) class is (pcm_nlo_t) !!! Check that Born integral is there if (.not. pcm%settings%combined_integration .and. & process%component_can_be_integrated (1)) then call results%record_correction (process%get_correction (), & process%get_correction_error ()) end if end select call results%display_final () end subroutine process_display_summed_results @ %def process_display_summed_results @ Run LaTeX/Metapost to generate a ps/pdf file for the integration history. We (re)write the driver file -- just in case it has been missed before -- then we compile it. <>= procedure :: display_integration_history => & process_display_integration_history <>= module subroutine process_display_integration_history & (process, i_mci, filename, os_data, eff_reset) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(string_t), intent(in) :: filename type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: eff_reset end subroutine process_display_integration_history <>= module subroutine process_display_integration_history & (process, i_mci, filename, os_data, eff_reset) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(string_t), intent(in) :: filename type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: eff_reset call integration_results_write_driver & (process%mci_entry(i_mci)%results, filename, eff_reset) call integration_results_compile_driver & (process%mci_entry(i_mci)%results, filename, os_data) end subroutine process_display_integration_history @ %def subroutine process_display_integration_history @ Write a complete logfile (with hardcoded name based on the process ID). We do not write internal data. <>= procedure :: write_logfile => process_write_logfile <>= module subroutine process_write_logfile (process, i_mci, filename) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(string_t), intent(in) :: filename end subroutine process_write_logfile <>= module subroutine process_write_logfile (process, i_mci, filename) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(string_t), intent(in) :: filename type(time_t) :: time integer :: unit, u unit = free_unit () open (unit = unit, file = char (filename), action = "write", & status = "replace") u = given_output_unit (unit) write (u, "(A)") repeat ("#", 79) call process%meta%write (u, .false.) write (u, "(A)") repeat ("#", 79) write (u, "(3x,A,ES17.10)") "Integral = ", & process%mci_entry(i_mci)%get_integral () write (u, "(3x,A,ES17.10)") "Error = ", & process%mci_entry(i_mci)%get_error () write (u, "(3x,A,ES17.10)") "Accuracy = ", & process%mci_entry(i_mci)%get_accuracy () write (u, "(3x,A,ES17.10)") "Chi2 = ", & process%mci_entry(i_mci)%get_chi2 () write (u, "(3x,A,ES17.10)") "Efficiency = ", & process%mci_entry(i_mci)%get_efficiency () call process%mci_entry(i_mci)%get_time (time, 10000) if (time%is_known ()) then write (u, "(3x,A,1x,A)") "T(10k evt) = ", char (time%to_string_dhms ()) else write (u, "(3x,A)") "T(10k evt) = [undefined]" end if call process%mci_entry(i_mci)%results%write (u) write (u, "(A)") repeat ("#", 79) call process%mci_entry(i_mci)%results%write_chain_weights (u) write (u, "(A)") repeat ("#", 79) call process%mci_entry(i_mci)%counter%write (u) write (u, "(A)") repeat ("#", 79) call process%mci_entry(i_mci)%mci%write_log_entry (u) write (u, "(A)") repeat ("#", 79) call process%beam_config%data%write (u) write (u, "(A)") repeat ("#", 79) if (allocated (process%config%ef_cuts)) then write (u, "(3x,A)") "Cut expression:" call process%config%ef_cuts%write (u) else write (u, "(3x,A)") "No cuts used." end if call write_separator (u) if (allocated (process%config%ef_scale)) then write (u, "(3x,A)") "Scale expression:" call process%config%ef_scale%write (u) else write (u, "(3x,A)") "No scale expression was given." end if call write_separator (u) if (allocated (process%config%ef_fac_scale)) then write (u, "(3x,A)") "Factorization scale expression:" call process%config%ef_fac_scale%write (u) else write (u, "(3x,A)") "No factorization scale expression was given." end if call write_separator (u) if (allocated (process%config%ef_ren_scale)) then write (u, "(3x,A)") "Renormalization scale expression:" call process%config%ef_ren_scale%write (u) else write (u, "(3x,A)") "No renormalization scale expression was given." end if call write_separator (u) if (allocated (process%config%ef_weight)) then call write_separator (u) write (u, "(3x,A)") "Weight expression:" call process%config%ef_weight%write (u) else write (u, "(3x,A)") "No weight expression was given." end if write (u, "(A)") repeat ("#", 79) write (u, "(1x,A)") "Summary of quantum-number states:" write (u, "(1x,A)") " + sign: allowed and contributing" write (u, "(1x,A)") " no + : switched off at runtime" call process%write_state_summary (u) write (u, "(A)") repeat ("#", 79) call process%env%write (u, show_var_list=.true., & show_model=.false., show_lib=.false., show_os_data=.false.) write (u, "(A)") repeat ("#", 79) close (u) end subroutine process_write_logfile @ %def process_write_logfile @ Display the quantum-number combinations of the process components, and their current status (allowed or switched off). <>= procedure :: write_state_summary => process_write_state_summary <>= module subroutine process_write_state_summary (process, unit) class(process_t), intent(in) :: process integer, intent(in), optional :: unit end subroutine process_write_state_summary <>= module subroutine process_write_state_summary (process, unit) class(process_t), intent(in) :: process integer, intent(in), optional :: unit integer :: i, i_component, u u = given_output_unit (unit) do i = 1, size (process%term) call write_separator (u) i_component = process%term(i)%i_component if (i_component /= 0) then call process%term(i)%write_state_summary & (process%get_core_term(i), unit) end if end do end subroutine process_write_state_summary @ %def process_write_state_summary @ Prepare event generation for the specified MCI entry. This implies, in particular, checking the phase-space file. <>= procedure :: prepare_simulation => process_prepare_simulation <>= module subroutine process_prepare_simulation (process, i_mci) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci end subroutine process_prepare_simulation <>= module subroutine process_prepare_simulation (process, i_mci) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci call process%mci_entry(i_mci)%prepare_simulation () end subroutine process_prepare_simulation @ %def process_prepare_simulation @ \subsubsection{Retrieve process data} Tell whether integral (and error) are known. <>= generic :: has_integral => has_integral_tot, has_integral_mci procedure :: has_integral_tot => process_has_integral_tot procedure :: has_integral_mci => process_has_integral_mci <>= module function process_has_integral_tot (process) result (flag) logical :: flag class(process_t), intent(in) :: process end function process_has_integral_tot module function process_has_integral_mci (process, i_mci) result (flag) logical :: flag class(process_t), intent(in) :: process integer, intent(in) :: i_mci end function process_has_integral_mci <>= module function process_has_integral_mci (process, i_mci) result (flag) logical :: flag class(process_t), intent(in) :: process integer, intent(in) :: i_mci if (allocated (process%mci_entry)) then flag = process%mci_entry(i_mci)%has_integral () else flag = .false. end if end function process_has_integral_mci module function process_has_integral_tot (process) result (flag) logical :: flag class(process_t), intent(in) :: process integer :: i, j, i_component if (allocated (process%mci_entry)) then flag = .true. do i = 1, size (process%mci_entry) do j = 1, size (process%mci_entry(i)%i_component) i_component = process%mci_entry(i)%i_component(j) if (process%component_can_be_integrated (i_component)) & flag = flag .and. process%mci_entry(i)%has_integral () end do end do else flag = .false. end if end function process_has_integral_tot @ %def process_has_integral @ Return the current integral and error obtained by the integrator [[i_mci]]. <>= generic :: get_integral => get_integral_tot, get_integral_mci generic :: get_error => get_error_tot, get_error_mci generic :: get_efficiency => get_efficiency_tot, get_efficiency_mci procedure :: get_integral_tot => process_get_integral_tot procedure :: get_integral_mci => process_get_integral_mci procedure :: get_error_tot => process_get_error_tot procedure :: get_error_mci => process_get_error_mci procedure :: get_efficiency_tot => process_get_efficiency_tot procedure :: get_efficiency_mci => process_get_efficiency_mci <>= module function process_get_integral_mci (process, i_mci) result (integral) real(default) :: integral class(process_t), intent(in) :: process integer, intent(in) :: i_mci end function process_get_integral_mci module function process_get_error_mci (process, i_mci) result (error) real(default) :: error class(process_t), intent(in) :: process integer, intent(in) :: i_mci end function process_get_error_mci module function process_get_efficiency_mci & (process, i_mci) result (efficiency) real(default) :: efficiency class(process_t), intent(in) :: process integer, intent(in) :: i_mci end function process_get_efficiency_mci module function process_get_integral_tot (process) result (integral) real(default) :: integral class(process_t), intent(in) :: process end function process_get_integral_tot module function process_get_error_tot (process) result (error) real(default) :: variance class(process_t), intent(in) :: process real(default) :: error end function process_get_error_tot module function process_get_efficiency_tot (process) result (efficiency) real(default) :: efficiency class(process_t), intent(in) :: process end function process_get_efficiency_tot <>= module function process_get_integral_mci (process, i_mci) result (integral) real(default) :: integral class(process_t), intent(in) :: process integer, intent(in) :: i_mci integral = process%mci_entry(i_mci)%get_integral () end function process_get_integral_mci module function process_get_error_mci (process, i_mci) result (error) real(default) :: error class(process_t), intent(in) :: process integer, intent(in) :: i_mci error = process%mci_entry(i_mci)%get_error () end function process_get_error_mci module function process_get_efficiency_mci & (process, i_mci) result (efficiency) real(default) :: efficiency class(process_t), intent(in) :: process integer, intent(in) :: i_mci efficiency = process%mci_entry(i_mci)%get_efficiency () end function process_get_efficiency_mci module function process_get_integral_tot (process) result (integral) real(default) :: integral class(process_t), intent(in) :: process integer :: i, j, i_component integral = zero if (allocated (process%mci_entry)) then do i = 1, size (process%mci_entry) do j = 1, size (process%mci_entry(i)%i_component) i_component = process%mci_entry(i)%i_component(j) if (process%component_can_be_integrated(i_component)) & integral = integral + process%mci_entry(i)%get_integral () end do end do end if end function process_get_integral_tot module function process_get_error_tot (process) result (error) real(default) :: variance class(process_t), intent(in) :: process real(default) :: error integer :: i, j, i_component variance = zero if (allocated (process%mci_entry)) then do i = 1, size (process%mci_entry) do j = 1, size (process%mci_entry(i)%i_component) i_component = process%mci_entry(i)%i_component(j) if (process%component_can_be_integrated(i_component)) & variance = variance + process%mci_entry(i)%get_error () ** 2 end do end do end if error = sqrt (variance) end function process_get_error_tot module function process_get_efficiency_tot (process) result (efficiency) real(default) :: efficiency class(process_t), intent(in) :: process real(default) :: den, eff, int integer :: i, j, i_component den = zero if (allocated (process%mci_entry)) then do i = 1, size (process%mci_entry) do j = 1, size (process%mci_entry(i)%i_component) i_component = process%mci_entry(i)%i_component(j) if (process%component_can_be_integrated(i_component)) then int = process%get_integral (i) if (int > 0) then eff = process%mci_entry(i)%get_efficiency () if (eff > 0) then den = den + int / eff else efficiency = 0 return end if end if end if end do end do end if if (den > 0) then efficiency = process%get_integral () / den else efficiency = 0 end if end function process_get_efficiency_tot @ %def process_get_integral process_get_efficiency @ Let us call the ratio of the NLO and the LO result $\iota = I_{NLO} / I_{LO}$. Then usual error propagation gives \begin{equation*} \sigma_{\iota}^2 = \left(\frac{\partial \iota}{\partial I_{LO}}\right)^2 \sigma_{I_{LO}}^2 + \left(\frac{\partial \iota}{\partial I_{NLO}}\right)^2 \sigma_{I_{NLO}}^2 = \frac{I_{NLO}^2\sigma_{I_{LO}}^2}{I_{LO}^4} + \frac{\sigma_{I_{NLO}}^2}{I_{LO}^2}. \end{equation*} <>= procedure :: get_correction => process_get_correction procedure :: get_correction_error => process_get_correction_error <>= module function process_get_correction (process) result (ratio) real(default) :: ratio class(process_t), intent(in) :: process end function process_get_correction module function process_get_correction_error (process) result (error) real(default) :: error class(process_t), intent(in) :: process end function process_get_correction_error <>= module function process_get_correction (process) result (ratio) real(default) :: ratio class(process_t), intent(in) :: process integer :: i_mci, i_component real(default) :: int_born, int_nlo int_nlo = zero int_born = process%mci_entry(1)%get_integral () i_mci = 2 do i_component = 2, size (process%component) if (process%component_can_be_integrated (i_component)) then int_nlo = int_nlo + process%mci_entry(i_mci)%get_integral () i_mci = i_mci + 1 end if end do ratio = int_nlo / int_born * 100 end function process_get_correction module function process_get_correction_error (process) result (error) real(default) :: error class(process_t), intent(in) :: process real(default) :: int_born, sum_int_nlo real(default) :: err_born, err2 integer :: i_mci, i_component sum_int_nlo = zero; err2 = zero int_born = process%mci_entry(1)%get_integral () err_born = process%mci_entry(1)%get_error () i_mci = 2 do i_component = 2, size (process%component) if (process%component_can_be_integrated (i_component)) then sum_int_nlo = sum_int_nlo + process%mci_entry(i_mci)%get_integral () err2 = err2 + process%mci_entry(i_mci)%get_error()**2 i_mci = i_mci + 1 end if end do error = sqrt (err2 / int_born**2 + sum_int_nlo**2 * err_born**2 / int_born**4) * 100 end function process_get_correction_error @ %def process_get_correction process_get_correction_error @ This routine asks [[beam_config]] for the frame. <>= procedure :: lab_is_cm => process_lab_is_cm <>= pure module function process_lab_is_cm (process) result (lab_is_cm) logical :: lab_is_cm class(process_t), intent(in) :: process end function process_lab_is_cm <>= pure module function process_lab_is_cm (process) result (lab_is_cm) logical :: lab_is_cm class(process_t), intent(in) :: process lab_is_cm = process%beam_config%lab_is_cm end function process_lab_is_cm @ %def process_lab_is_cm @ <>= procedure :: get_component_ptr => process_get_component_ptr <>= module function process_get_component_ptr (process, i) result (component) type(process_component_t), pointer :: component class(process_t), intent(in), target :: process integer, intent(in) :: i end function process_get_component_ptr <>= module function process_get_component_ptr (process, i) result (component) type(process_component_t), pointer :: component class(process_t), intent(in), target :: process integer, intent(in) :: i component => process%component(i) end function process_get_component_ptr @ %def process_get_component_ptr @ <>= procedure :: get_qcd => process_get_qcd <>= module function process_get_qcd (process) result (qcd) type(qcd_t) :: qcd class(process_t), intent(in) :: process end function process_get_qcd <>= module function process_get_qcd (process) result (qcd) type(qcd_t) :: qcd class(process_t), intent(in) :: process qcd = process%config%get_qcd () end function process_get_qcd @ %def process_get_qcd @ <>= generic :: get_component_type => get_component_type_single procedure :: get_component_type_single => process_get_component_type_single <>= elemental module function process_get_component_type_single & (process, i_component) result (comp_type) integer :: comp_type class(process_t), intent(in) :: process integer, intent(in) :: i_component end function process_get_component_type_single <>= elemental module function process_get_component_type_single & (process, i_component) result (comp_type) integer :: comp_type class(process_t), intent(in) :: process integer, intent(in) :: i_component comp_type = process%component(i_component)%component_type end function process_get_component_type_single @ %def process_get_component_type_single @ <>= generic :: get_component_type => get_component_type_all procedure :: get_component_type_all => process_get_component_type_all <>= module function process_get_component_type_all & (process) result (comp_type) integer, dimension(:), allocatable :: comp_type class(process_t), intent(in) :: process end function process_get_component_type_all <>= module function process_get_component_type_all & (process) result (comp_type) integer, dimension(:), allocatable :: comp_type class(process_t), intent(in) :: process allocate (comp_type (size (process%component))) comp_type = process%component%component_type end function process_get_component_type_all @ %def process_get_component_type_all @ <>= procedure :: get_component_i_terms => process_get_component_i_terms <>= module function process_get_component_i_terms & (process, i_component) result (i_term) integer, dimension(:), allocatable :: i_term class(process_t), intent(in) :: process integer, intent(in) :: i_component end function process_get_component_i_terms <>= module function process_get_component_i_terms & (process, i_component) result (i_term) integer, dimension(:), allocatable :: i_term class(process_t), intent(in) :: process integer, intent(in) :: i_component allocate (i_term (size (process%component(i_component)%i_term))) i_term = process%component(i_component)%i_term end function process_get_component_i_terms @ %def process_get_component_i_terms @ <>= procedure :: get_n_allowed_born => process_get_n_allowed_born <>= module function process_get_n_allowed_born (process, i_born) result (n_born) class(process_t), intent(inout) :: process integer, intent(in) :: i_born integer :: n_born end function process_get_n_allowed_born <>= module function process_get_n_allowed_born (process, i_born) result (n_born) class(process_t), intent(inout) :: process integer, intent(in) :: i_born integer :: n_born n_born = process%term(i_born)%n_allowed end function process_get_n_allowed_born @ %def process_get_n_allowed_born @ Workaround getter. Would be better to remove this. <>= procedure :: get_pcm_ptr => process_get_pcm_ptr <>= module function process_get_pcm_ptr (process) result (pcm) class(pcm_t), pointer :: pcm class(process_t), intent(in), target :: process end function process_get_pcm_ptr <>= module function process_get_pcm_ptr (process) result (pcm) class(pcm_t), pointer :: pcm class(process_t), intent(in), target :: process pcm => process%pcm end function process_get_pcm_ptr @ %def process_get_pcm_ptr <>= generic :: component_can_be_integrated => component_can_be_integrated_single generic :: component_can_be_integrated => component_can_be_integrated_all procedure :: component_can_be_integrated_single => & process_component_can_be_integrated_single <>= module function process_component_can_be_integrated_single & (process, i_component) result (active) logical :: active class(process_t), intent(in) :: process integer, intent(in) :: i_component end function process_component_can_be_integrated_single <>= module function process_component_can_be_integrated_single & (process, i_component) result (active) logical :: active class(process_t), intent(in) :: process integer, intent(in) :: i_component logical :: combined_integration select type (pcm => process%pcm) type is (pcm_nlo_t) combined_integration = pcm%settings%combined_integration class default combined_integration = .false. end select associate (component => process%component(i_component)) active = component%can_be_integrated () if (combined_integration) & active = active .and. component%component_type <= COMP_MASTER end associate end function process_component_can_be_integrated_single @ %def process_component_can_be_integrated_single @ <>= procedure :: component_can_be_integrated_all => & process_component_can_be_integrated_all <>= module function process_component_can_be_integrated_all & (process) result (val) logical, dimension(:), allocatable :: val class(process_t), intent(in) :: process end function process_component_can_be_integrated_all <>= module function process_component_can_be_integrated_all (process) result (val) logical, dimension(:), allocatable :: val class(process_t), intent(in) :: process integer :: i allocate (val (size (process%component))) do i = 1, size (process%component) val(i) = process%component_can_be_integrated (i) end do end function process_component_can_be_integrated_all @ %def process_component_can_be_integrated_all @ <>= procedure :: reset_selected_cores => process_reset_selected_cores <>= pure module subroutine process_reset_selected_cores (process) class(process_t), intent(inout) :: process end subroutine process_reset_selected_cores <>= pure module subroutine process_reset_selected_cores (process) class(process_t), intent(inout) :: process process%pcm%component_selected = .false. end subroutine process_reset_selected_cores @ %def process_reset_selected_cores @ <>= procedure :: select_components => process_select_components <>= pure module subroutine process_select_components (process, indices) class(process_t), intent(inout) :: process integer, dimension(:), intent(in) :: indices end subroutine process_select_components <>= pure module subroutine process_select_components (process, indices) class(process_t), intent(inout) :: process integer, dimension(:), intent(in) :: indices associate (pcm => process%pcm) pcm%component_selected(indices) = .true. end associate end subroutine process_select_components @ %def process_select_components @ <>= procedure :: component_is_selected => process_component_is_selected <>= pure module function process_component_is_selected & (process, index) result (val) logical :: val class(process_t), intent(in) :: process integer, intent(in) :: index end function process_component_is_selected <>= pure module function process_component_is_selected & (process, index) result (val) logical :: val class(process_t), intent(in) :: process integer, intent(in) :: index associate (pcm => process%pcm) val = pcm%component_selected(index) end associate end function process_component_is_selected @ %def process_component_is_selected @ <>= procedure :: get_coupling_powers => process_get_coupling_powers <>= pure module subroutine process_get_coupling_powers & (process, alpha_power, alphas_power) class(process_t), intent(in) :: process integer, intent(out) :: alpha_power, alphas_power end subroutine process_get_coupling_powers <>= pure module subroutine process_get_coupling_powers & (process, alpha_power, alphas_power) class(process_t), intent(in) :: process integer, intent(out) :: alpha_power, alphas_power call process%component(1)%config%get_coupling_powers & (alpha_power, alphas_power) end subroutine process_get_coupling_powers @ %def process_get_coupling_powers @ <>= procedure :: get_real_component => process_get_real_component <>= module function process_get_real_component (process) result (i_real) integer :: i_real class(process_t), intent(in) :: process end function process_get_real_component <>= module function process_get_real_component (process) result (i_real) integer :: i_real class(process_t), intent(in) :: process integer :: i_component type(process_component_def_t), pointer :: config => null () i_real = 0 do i_component = 1, size (process%component) config => process%get_component_def_ptr (i_component) if (config%get_nlo_type () == NLO_REAL) then i_real = i_component exit end if end do end function process_get_real_component @ %def process_get_real_component @ <>= procedure :: extract_active_component_mci => & process_extract_active_component_mci <>= module function process_extract_active_component_mci & (process) result (i_active) integer :: i_active class(process_t), intent(in) :: process end function process_extract_active_component_mci <>= module function process_extract_active_component_mci & (process) result (i_active) integer :: i_active class(process_t), intent(in) :: process integer :: i_mci, j, i_component, n_active call count_n_active () if (n_active /= 1) i_active = 0 contains subroutine count_n_active () n_active = 0 do i_mci = 1, size (process%mci_entry) associate (mci_entry => process%mci_entry(i_mci)) do j = 1, size (mci_entry%i_component) i_component = mci_entry%i_component(j) associate (component => process%component (i_component)) if (component%can_be_integrated ()) then i_active = i_mci n_active = n_active + 1 end if end associate end do end associate end do end subroutine count_n_active end function process_extract_active_component_mci @ %def process_extract_active_component_mci @ <>= procedure :: uses_real_partition => process_uses_real_partition <>= module function process_uses_real_partition (process) result (val) logical :: val class(process_t), intent(in) :: process end function process_uses_real_partition <>= module function process_uses_real_partition (process) result (val) logical :: val class(process_t), intent(in) :: process val = any (process%mci_entry%real_partition_type /= REAL_FULL) end function process_uses_real_partition @ %def process_uses_real_partition @ Return the MD5 sums that summarize the process component definitions. These values should be independent of parameters, beam details, expressions, etc. They can be used for checking the integrity of a process when reusing an old event file. <>= procedure :: get_md5sum_prc => process_get_md5sum_prc <>= module function process_get_md5sum_prc & (process, i_component) result (md5sum) character(32) :: md5sum class(process_t), intent(in) :: process integer, intent(in) :: i_component end function process_get_md5sum_prc <>= module function process_get_md5sum_prc (process, i_component) result (md5sum) character(32) :: md5sum class(process_t), intent(in) :: process integer, intent(in) :: i_component if (process%component(i_component)%active) then md5sum = process%component(i_component)%config%get_md5sum () else md5sum = "" end if end function process_get_md5sum_prc @ %def process_get_md5sum_prc @ Return the MD5 sums that summarize the state of the MCI integrators. These values should encode all process data, integration and phase space configuration, etc., and the integration results. They can thus be used for checking the integrity of an event-generation setup when reusing an old event file. <>= procedure :: get_md5sum_mci => process_get_md5sum_mci <>= module function process_get_md5sum_mci (process, i_mci) result (md5sum) character(32) :: md5sum class(process_t), intent(in) :: process integer, intent(in) :: i_mci end function process_get_md5sum_mci <>= module function process_get_md5sum_mci (process, i_mci) result (md5sum) character(32) :: md5sum class(process_t), intent(in) :: process integer, intent(in) :: i_mci md5sum = process%mci_entry(i_mci)%get_md5sum () end function process_get_md5sum_mci @ %def process_get_md5sum_mci @ Return the MD5 sum of the process configuration. This should encode the process setup, data, and expressions, but no integration results. <>= procedure :: get_md5sum_cfg => process_get_md5sum_cfg <>= module function process_get_md5sum_cfg (process) result (md5sum) character(32) :: md5sum class(process_t), intent(in) :: process end function process_get_md5sum_cfg <>= module function process_get_md5sum_cfg (process) result (md5sum) character(32) :: md5sum class(process_t), intent(in) :: process md5sum = process%config%md5sum end function process_get_md5sum_cfg @ %def process_get_md5sum_cfg @ <>= procedure :: get_n_cores => process_get_n_cores <>= module function process_get_n_cores (process) result (n) integer :: n class(process_t), intent(in) :: process end function process_get_n_cores <>= module function process_get_n_cores (process) result (n) integer :: n class(process_t), intent(in) :: process n = process%pcm%n_cores end function process_get_n_cores @ %def process_get_n_cores @ <>= procedure :: get_base_i_term => process_get_base_i_term <>= module function process_get_base_i_term & (process, i_component) result (i_term) integer :: i_term class(process_t), intent(in) :: process integer, intent(in) :: i_component end function process_get_base_i_term <>= module function process_get_base_i_term (process, i_component) result (i_term) integer :: i_term class(process_t), intent(in) :: process integer, intent(in) :: i_component i_term = process%component(i_component)%i_term(1) end function process_get_base_i_term @ %def process_get_base_i_term @ <>= procedure :: get_core_term => process_get_core_term <>= module function process_get_core_term (process, i_term) result (core) class(prc_core_t), pointer :: core class(process_t), intent(in), target :: process integer, intent(in) :: i_term end function process_get_core_term <>= module function process_get_core_term (process, i_term) result (core) class(prc_core_t), pointer :: core class(process_t), intent(in), target :: process integer, intent(in) :: i_term integer :: i_core i_core = process%term(i_term)%i_core core => process%core_entry(i_core)%get_core_ptr () end function process_get_core_term @ %def process_get_core_term @ <>= procedure :: get_core_ptr => process_get_core_ptr <>= module function process_get_core_ptr (process, i_core) result (core) class(prc_core_t), pointer :: core class(process_t), intent(in), target :: process integer, intent(in) :: i_core end function process_get_core_ptr <>= module function process_get_core_ptr (process, i_core) result (core) class(prc_core_t), pointer :: core class(process_t), intent(in), target :: process integer, intent(in) :: i_core if (allocated (process%core_entry)) then core => process%core_entry(i_core)%get_core_ptr () else core => null () end if end function process_get_core_ptr @ %def process_get_core_ptr @ <>= procedure :: get_term_ptr => process_get_term_ptr <>= module function process_get_term_ptr (process, i) result (term) type(process_term_t), pointer :: term class(process_t), intent(in), target :: process integer, intent(in) :: i end function process_get_term_ptr <>= module function process_get_term_ptr (process, i) result (term) type(process_term_t), pointer :: term class(process_t), intent(in), target :: process integer, intent(in) :: i term => process%term(i) end function process_get_term_ptr @ %def process_get_term_ptr @ <>= procedure :: get_i_term => process_get_i_term <>= module function process_get_i_term (process, i_core) result (i_term) integer :: i_term class(process_t), intent(in) :: process integer, intent(in) :: i_core end function process_get_i_term <>= module function process_get_i_term (process, i_core) result (i_term) integer :: i_term class(process_t), intent(in) :: process integer, intent(in) :: i_core do i_term = 1, process%get_n_terms () if (process%term(i_term)%i_core == i_core) return end do i_term = -1 end function process_get_i_term @ %def process_get_i_term @ <>= procedure :: get_i_core => process_get_i_core <>= module function process_get_i_core (process, i_term) result (i_core) class(process_t), intent(in) :: process integer, intent(in) :: i_term integer :: i_core end function process_get_i_core <>= module function process_get_i_core (process, i_term) result (i_core) class(process_t), intent(in) :: process integer, intent(in) :: i_term integer :: i_core i_core = process%term(i_term)%i_core end function process_get_i_core @ %def process_get_i_core @ <>= procedure :: set_i_mci_work => process_set_i_mci_work <>= module subroutine process_set_i_mci_work (process, i_mci) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci end subroutine process_set_i_mci_work <>= module subroutine process_set_i_mci_work (process, i_mci) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci process%mci_entry(i_mci)%i_mci = i_mci end subroutine process_set_i_mci_work @ %def process_set_i_mci_work @ <>= procedure :: get_i_mci_work => process_get_i_mci_work <>= pure module function process_get_i_mci_work & (process, i_mci) result (i_mci_work) integer :: i_mci_work class(process_t), intent(in) :: process integer, intent(in) :: i_mci end function process_get_i_mci_work <>= pure module function process_get_i_mci_work & (process, i_mci) result (i_mci_work) integer :: i_mci_work class(process_t), intent(in) :: process integer, intent(in) :: i_mci i_mci_work = process%mci_entry(i_mci)%i_mci end function process_get_i_mci_work @ %def process_get_i_mci_work @ <>= procedure :: get_i_sub => process_get_i_sub <>= elemental module function process_get_i_sub (process, i_term) result (i_sub) integer :: i_sub class(process_t), intent(in) :: process integer, intent(in) :: i_term end function process_get_i_sub <>= elemental module function process_get_i_sub (process, i_term) result (i_sub) integer :: i_sub class(process_t), intent(in) :: process integer, intent(in) :: i_term i_sub = process%term(i_term)%i_sub end function process_get_i_sub @ %def process_get_i_sub @ <>= procedure :: get_i_term_virtual => process_get_i_term_virtual <>= elemental module function process_get_i_term_virtual & (process) result (i_term) integer :: i_term class(process_t), intent(in) :: process end function process_get_i_term_virtual <>= elemental module function process_get_i_term_virtual (process) result (i_term) integer :: i_term class(process_t), intent(in) :: process integer :: i_component i_term = 0 do i_component = 1, size (process%component) if (process%component(i_component)%get_nlo_type () == NLO_VIRTUAL) & i_term = process%component(i_component)%i_term(1) end do end function process_get_i_term_virtual @ %def process_get_i_term_virtual @ <>= generic :: component_is_active => component_is_active_single procedure :: component_is_active_single => process_component_is_active_single <>= elemental module function process_component_is_active_single & (process, i_comp) result (val) logical :: val class(process_t), intent(in) :: process integer, intent(in) :: i_comp end function process_component_is_active_single <>= elemental module function process_component_is_active_single & (process, i_comp) result (val) logical :: val class(process_t), intent(in) :: process integer, intent(in) :: i_comp val = process%component(i_comp)%is_active () end function process_component_is_active_single @ %def process_component_is_active_single @ <>= generic :: component_is_active => component_is_active_all procedure :: component_is_active_all => process_component_is_active_all <>= pure module function process_component_is_active_all (process) result (val) logical, dimension(:), allocatable :: val class(process_t), intent(in) :: process end function process_component_is_active_all <>= pure module function process_component_is_active_all (process) result (val) logical, dimension(:), allocatable :: val class(process_t), intent(in) :: process allocate (val (size (process%component))) val = process%component%is_active () end function process_component_is_active_all @ %def process_component_is_active_all @ \subsection{Default iterations} If the user does not specify the passes and iterations for integration, we should be able to give reasonable defaults. These depend on the process, therefore we implement the following procedures as methods of the process object. The algorithm is not very sophisticated yet, it may be improved by looking at the process in more detail. We investigate only the first process component, assuming that it characterizes the complexity of the process reasonable well. The number of passes is limited to two: one for adaption, one for integration. <>= procedure :: get_n_pass_default => process_get_n_pass_default procedure :: adapt_grids_default => process_adapt_grids_default procedure :: adapt_weights_default => process_adapt_weights_default <>= module function process_get_n_pass_default (process) result (n_pass) class(process_t), intent(in) :: process integer :: n_pass end function process_get_n_pass_default module function process_adapt_grids_default (process, pass) result (flag) class(process_t), intent(in) :: process integer, intent(in) :: pass logical :: flag end function process_adapt_grids_default module function process_adapt_weights_default (process, pass) result (flag) class(process_t), intent(in) :: process integer, intent(in) :: pass logical :: flag end function process_adapt_weights_default <>= module function process_get_n_pass_default (process) result (n_pass) class(process_t), intent(in) :: process integer :: n_pass integer :: n_eff type(process_component_def_t), pointer :: config config => process%component(1)%config n_eff = config%get_n_tot () - 2 select case (n_eff) case (1) n_pass = 1 case default n_pass = 2 end select end function process_get_n_pass_default module function process_adapt_grids_default (process, pass) result (flag) class(process_t), intent(in) :: process integer, intent(in) :: pass logical :: flag integer :: n_eff type(process_component_def_t), pointer :: config config => process%component(1)%config n_eff = config%get_n_tot () - 2 select case (n_eff) case (1) flag = .false. case default select case (pass) case (1); flag = .true. case (2); flag = .false. case default call msg_bug ("adapt grids default: impossible pass index") end select end select end function process_adapt_grids_default module function process_adapt_weights_default (process, pass) result (flag) class(process_t), intent(in) :: process integer, intent(in) :: pass logical :: flag integer :: n_eff type(process_component_def_t), pointer :: config config => process%component(1)%config n_eff = config%get_n_tot () - 2 select case (n_eff) case (1) flag = .false. case default select case (pass) case (1); flag = .true. case (2); flag = .false. case default call msg_bug ("adapt weights default: impossible pass index") end select end select end function process_adapt_weights_default @ %def process_get_n_pass_default @ %def process_adapt_grids_default @ %def process_adapt_weights_default @ The number of iterations and calls per iteration depends on the number of outgoing particles. <>= procedure :: get_n_it_default => process_get_n_it_default procedure :: get_n_calls_default => process_get_n_calls_default <>= module function process_get_n_it_default (process, pass) result (n_it) class(process_t), intent(in) :: process integer, intent(in) :: pass integer :: n_it end function process_get_n_it_default module function process_get_n_calls_default (process, pass) result (n_calls) class(process_t), intent(in) :: process integer, intent(in) :: pass integer :: n_calls end function process_get_n_calls_default <>= module function process_get_n_it_default (process, pass) result (n_it) class(process_t), intent(in) :: process integer, intent(in) :: pass integer :: n_it integer :: n_eff type(process_component_def_t), pointer :: config config => process%component(1)%config n_eff = config%get_n_tot () - 2 select case (pass) case (1) select case (n_eff) case (1); n_it = 1 case (2); n_it = 3 case (3); n_it = 5 case (4:5); n_it = 10 case (6); n_it = 15 case (7:); n_it = 20 end select case (2) select case (n_eff) case (:3); n_it = 3 case (4:); n_it = 5 end select end select end function process_get_n_it_default module function process_get_n_calls_default (process, pass) result (n_calls) class(process_t), intent(in) :: process integer, intent(in) :: pass integer :: n_calls integer :: n_eff type(process_component_def_t), pointer :: config config => process%component(1)%config n_eff = config%get_n_tot () - 2 select case (pass) case (1) select case (n_eff) case (1); n_calls = 100 case (2); n_calls = 1000 case (3); n_calls = 5000 case (4); n_calls = 10000 case (5); n_calls = 20000 case (6:); n_calls = 50000 end select case (2) select case (n_eff) case (:3); n_calls = 10000 case (4); n_calls = 20000 case (5); n_calls = 50000 case (6); n_calls = 100000 case (7:); n_calls = 200000 end select end select end function process_get_n_calls_default @ %def process_get_n_it_default @ %def process_get_n_calls_default @ \subsection{Constant process data} Manually set the Run ID (unit test only). <>= procedure :: set_run_id => process_set_run_id <>= module subroutine process_set_run_id (process, run_id) class(process_t), intent(inout) :: process type(string_t), intent(in) :: run_id end subroutine process_set_run_id <>= module subroutine process_set_run_id (process, run_id) class(process_t), intent(inout) :: process type(string_t), intent(in) :: run_id process%meta%run_id = run_id end subroutine process_set_run_id @ %def process_set_run_id @ The following methods return basic process data that stay constant after initialization. The process and IDs. <>= procedure :: get_id => process_get_id procedure :: get_num_id => process_get_num_id procedure :: get_run_id => process_get_run_id procedure :: get_library_name => process_get_library_name <>= module function process_get_id (process) result (id) class(process_t), intent(in) :: process type(string_t) :: id end function process_get_id module function process_get_num_id (process) result (id) class(process_t), intent(in) :: process integer :: id end function process_get_num_id module function process_get_run_id (process) result (id) class(process_t), intent(in) :: process type(string_t) :: id end function process_get_run_id module function process_get_library_name (process) result (id) class(process_t), intent(in) :: process type(string_t) :: id end function process_get_library_name <>= module function process_get_id (process) result (id) class(process_t), intent(in) :: process type(string_t) :: id id = process%meta%id end function process_get_id module function process_get_num_id (process) result (id) class(process_t), intent(in) :: process integer :: id id = process%meta%num_id end function process_get_num_id module function process_get_run_id (process) result (id) class(process_t), intent(in) :: process type(string_t) :: id id = process%meta%run_id end function process_get_run_id module function process_get_library_name (process) result (id) class(process_t), intent(in) :: process type(string_t) :: id id = process%meta%lib_name end function process_get_library_name @ %def process_get_id process_get_num_id @ %def process_get_run_id process_get_library_name @ The number of incoming particles. <>= procedure :: get_n_in => process_get_n_in <>= module function process_get_n_in (process) result (n) class(process_t), intent(in) :: process integer :: n end function process_get_n_in <>= module function process_get_n_in (process) result (n) class(process_t), intent(in) :: process integer :: n n = process%config%n_in end function process_get_n_in @ %def process_get_n_in @ The number of MCI data sets. <>= procedure :: get_n_mci => process_get_n_mci <>= module function process_get_n_mci (process) result (n) class(process_t), intent(in) :: process integer :: n end function process_get_n_mci <>= module function process_get_n_mci (process) result (n) class(process_t), intent(in) :: process integer :: n n = process%config%n_mci end function process_get_n_mci @ %def process_get_n_mci @ The number of process components, total. <>= procedure :: get_n_components => process_get_n_components <>= module function process_get_n_components (process) result (n) class(process_t), intent(in) :: process integer :: n end function process_get_n_components <>= module function process_get_n_components (process) result (n) class(process_t), intent(in) :: process integer :: n n = process%meta%n_components end function process_get_n_components @ %def process_get_n_components @ The number of process terms, total. <>= procedure :: get_n_terms => process_get_n_terms <>= module function process_get_n_terms (process) result (n) class(process_t), intent(in) :: process integer :: n end function process_get_n_terms <>= module function process_get_n_terms (process) result (n) class(process_t), intent(in) :: process integer :: n n = process%config%n_terms end function process_get_n_terms @ %def process_get_n_terms @ Return the indices of the components that belong to a specific MCI entry. <>= procedure :: get_i_component => process_get_i_component <>= module subroutine process_get_i_component (process, i_mci, i_component) class(process_t), intent(in) :: process integer, intent(in) :: i_mci integer, dimension(:), intent(out), allocatable :: i_component end subroutine process_get_i_component <>= module subroutine process_get_i_component (process, i_mci, i_component) class(process_t), intent(in) :: process integer, intent(in) :: i_mci integer, dimension(:), intent(out), allocatable :: i_component associate (mci_entry => process%mci_entry(i_mci)) allocate (i_component (size (mci_entry%i_component))) i_component = mci_entry%i_component end associate end subroutine process_get_i_component @ %def process_get_i_component @ Return the ID of a specific component. <>= procedure :: get_component_id => process_get_component_id <>= module function process_get_component_id (process, i_component) result (id) class(process_t), intent(in) :: process integer, intent(in) :: i_component type(string_t) :: id end function process_get_component_id <>= module function process_get_component_id (process, i_component) result (id) class(process_t), intent(in) :: process integer, intent(in) :: i_component type(string_t) :: id id = process%meta%component_id(i_component) end function process_get_component_id @ %def process_get_component_id @ Return a pointer to the definition of a specific component. <>= procedure :: get_component_def_ptr => process_get_component_def_ptr <>= module function process_get_component_def_ptr & (process, i_component) result (ptr) type(process_component_def_t), pointer :: ptr class(process_t), intent(in) :: process integer, intent(in) :: i_component end function process_get_component_def_ptr <>= module function process_get_component_def_ptr & (process, i_component) result (ptr) type(process_component_def_t), pointer :: ptr class(process_t), intent(in) :: process integer, intent(in) :: i_component ptr => process%config%process_def%get_component_def_ptr (i_component) end function process_get_component_def_ptr @ %def process_get_component_def_ptr @ These procedures extract and restore (by transferring the allocation) the process core. This is useful for changing process parameters from outside this module. <>= procedure :: extract_core => process_extract_core procedure :: restore_core => process_restore_core <>= module subroutine process_extract_core (process, i_term, core) class(process_t), intent(inout) :: process integer, intent(in) :: i_term class(prc_core_t), intent(inout), allocatable :: core end subroutine process_extract_core module subroutine process_restore_core (process, i_term, core) class(process_t), intent(inout) :: process integer, intent(in) :: i_term class(prc_core_t), intent(inout), allocatable :: core end subroutine process_restore_core <>= module subroutine process_extract_core (process, i_term, core) class(process_t), intent(inout) :: process integer, intent(in) :: i_term class(prc_core_t), intent(inout), allocatable :: core integer :: i_core i_core = process%term(i_term)%i_core call move_alloc (from = process%core_entry(i_core)%core, to = core) end subroutine process_extract_core module subroutine process_restore_core (process, i_term, core) class(process_t), intent(inout) :: process integer, intent(in) :: i_term class(prc_core_t), intent(inout), allocatable :: core integer :: i_core i_core = process%term(i_term)%i_core call move_alloc (from = core, to = process%core_entry(i_core)%core) end subroutine process_restore_core @ %def process_extract_core @ %def process_restore_core @ The block of process constants. <>= procedure :: get_constants => process_get_constants <>= module function process_get_constants (process, i_core) result (data) type(process_constants_t) :: data class(process_t), intent(in) :: process integer, intent(in) :: i_core end function process_get_constants <>= module function process_get_constants (process, i_core) result (data) type(process_constants_t) :: data class(process_t), intent(in) :: process integer, intent(in) :: i_core data = process%core_entry(i_core)%core%data end function process_get_constants @ %def process_get_constants @ <>= procedure :: get_config => process_get_config <>= module function process_get_config (process) result (config) type(process_config_data_t) :: config class(process_t), intent(in) :: process end function process_get_config <>= module function process_get_config (process) result (config) type(process_config_data_t) :: config class(process_t), intent(in) :: process config = process%config end function process_get_config @ %def process_get_config @ Construct an MD5 sum for the constant data, including the NLO type. For the NLO type [[NLO_MISMATCH]], we pretend that this was [[NLO_SUBTRACTION]] instead. TODO wk 2018: should not depend explicitly on NLO data. <>= procedure :: get_md5sum_constants => process_get_md5sum_constants <>= module function process_get_md5sum_constants (process, i_component, & type_string, nlo_type) result (this_md5sum) character(32) :: this_md5sum class(process_t), intent(in) :: process integer, intent(in) :: i_component type(string_t), intent(in) :: type_string integer, intent(in) :: nlo_type end function process_get_md5sum_constants <>= module function process_get_md5sum_constants (process, i_component, & type_string, nlo_type) result (this_md5sum) character(32) :: this_md5sum class(process_t), intent(in) :: process integer, intent(in) :: i_component type(string_t), intent(in) :: type_string integer, intent(in) :: nlo_type type(process_constants_t) :: data integer :: unit call process%env%fill_process_constants (process%meta%id, i_component, data) unit = data%fill_unit_for_md5sum (.false.) write (unit, '(A)') char(type_string) select case (nlo_type) case (NLO_MISMATCH) write (unit, '(I0)') NLO_SUBTRACTION case default write (unit, '(I0)') nlo_type end select rewind (unit) this_md5sum = md5sum (unit) close (unit) end function process_get_md5sum_constants @ %def process_get_md5sum_constants @ Return the set of outgoing flavors that are associated with a particular term. We deduce this from the effective interaction. <>= procedure :: get_term_flv_out => process_get_term_flv_out <>= module subroutine process_get_term_flv_out (process, i_term, flv) class(process_t), intent(in), target :: process integer, intent(in) :: i_term type(flavor_t), dimension(:,:), allocatable, intent(out) :: flv end subroutine process_get_term_flv_out <>= module subroutine process_get_term_flv_out (process, i_term, flv) class(process_t), intent(in), target :: process integer, intent(in) :: i_term type(flavor_t), dimension(:,:), allocatable, intent(out) :: flv type(interaction_t), pointer :: int int => process%term(i_term)%int_eff if (.not. associated (int)) int => process%term(i_term)%int call int%get_flv_out (flv) end subroutine process_get_term_flv_out @ %def process_get_term_flv_out @ Return true if there is any unstable particle in any of the process terms. We decide this based on the provided model instance, not the one that is stored in the process object. <>= procedure :: contains_unstable => process_contains_unstable <>= module function process_contains_unstable (process, model) result (flag) class(process_t), intent(in) :: process class(model_data_t), intent(in), target :: model logical :: flag end function process_contains_unstable <>= module function process_contains_unstable (process, model) result (flag) class(process_t), intent(in) :: process class(model_data_t), intent(in), target :: model logical :: flag integer :: i_term type(flavor_t), dimension(:,:), allocatable :: flv flag = .false. do i_term = 1, process%get_n_terms () call process%get_term_flv_out (i_term, flv) call flv%set_model (model) flag = .not. all (flv%is_stable ()) deallocate (flv) if (flag) return end do end function process_contains_unstable @ %def process_contains_unstable @ The nominal process energy. <>= procedure :: get_sqrts => process_get_sqrts <>= module function process_get_sqrts (process) result (sqrts) class(process_t), intent(in) :: process real(default) :: sqrts end function process_get_sqrts <>= module function process_get_sqrts (process) result (sqrts) class(process_t), intent(in) :: process real(default) :: sqrts sqrts = process%beam_config%data%get_sqrts () end function process_get_sqrts @ %def process_get_sqrts @ The lab-frame beam energy/energies.. <>= procedure :: get_energy => process_get_energy <>= module function process_get_energy (process) result (e) class(process_t), intent(in) :: process real(default), dimension(:), allocatable :: e end function process_get_energy <>= module function process_get_energy (process) result (e) class(process_t), intent(in) :: process real(default), dimension(:), allocatable :: e e = process%beam_config%data%get_energy () end function process_get_energy @ %def process_get_energy @ The beam polarization in case of simple degrees. <>= procedure :: get_polarization => process_get_polarization <>= module function process_get_polarization (process) result (pol) class(process_t), intent(in) :: process real(default), dimension(process%beam_config%data%n) :: pol end function process_get_polarization <>= module function process_get_polarization (process) result (pol) class(process_t), intent(in) :: process real(default), dimension(process%beam_config%data%n) :: pol pol = process%beam_config%data%get_polarization () end function process_get_polarization @ %def process_get_polarization @ <>= procedure :: get_meta => process_get_meta <>= module function process_get_meta (process) result (meta) type(process_metadata_t) :: meta class(process_t), intent(in) :: process end function process_get_meta <>= module function process_get_meta (process) result (meta) type(process_metadata_t) :: meta class(process_t), intent(in) :: process meta = process%meta end function process_get_meta @ %def process_get_meta <>= procedure :: has_matrix_element => process_has_matrix_element <>= module function process_has_matrix_element & (process, i, is_term_index) result (active) logical :: active class(process_t), intent(in) :: process integer, intent(in), optional :: i logical, intent(in), optional :: is_term_index end function process_has_matrix_element <>= module function process_has_matrix_element & (process, i, is_term_index) result (active) logical :: active class(process_t), intent(in) :: process integer, intent(in), optional :: i logical, intent(in), optional :: is_term_index integer :: i_component logical :: is_term is_term = .false. if (present (i)) then if (present (is_term_index)) is_term = is_term_index if (is_term) then i_component = process%term(i)%i_component else i_component = i end if active = process%component(i_component)%active else active = any (process%component%active) end if end function process_has_matrix_element @ %def process_has_matrix_element @ Pointer to the beam data object. <>= procedure :: get_beam_data_ptr => process_get_beam_data_ptr <>= module function process_get_beam_data_ptr (process) result (beam_data) class(process_t), intent(in), target :: process type(beam_data_t), pointer :: beam_data end function process_get_beam_data_ptr <>= module function process_get_beam_data_ptr (process) result (beam_data) class(process_t), intent(in), target :: process type(beam_data_t), pointer :: beam_data beam_data => process%beam_config%data end function process_get_beam_data_ptr @ %def process_get_beam_data_ptr @ <>= procedure :: get_beam_config => process_get_beam_config <>= module function process_get_beam_config (process) result (beam_config) type(process_beam_config_t) :: beam_config class(process_t), intent(in) :: process end function process_get_beam_config <>= module function process_get_beam_config (process) result (beam_config) type(process_beam_config_t) :: beam_config class(process_t), intent(in) :: process beam_config = process%beam_config end function process_get_beam_config @ %def process_get_beam_config @ <>= procedure :: get_beam_config_ptr => process_get_beam_config_ptr <>= module function process_get_beam_config_ptr (process) result (beam_config) type(process_beam_config_t), pointer :: beam_config class(process_t), intent(in), target :: process end function process_get_beam_config_ptr <>= module function process_get_beam_config_ptr (process) result (beam_config) type(process_beam_config_t), pointer :: beam_config class(process_t), intent(in), target :: process beam_config => process%beam_config end function process_get_beam_config_ptr @ %def process_get_beam_config_ptr @ Get the PDF set currently in use, if any. <>= procedure :: get_pdf_set => process_get_pdf_set <>= module function process_get_pdf_set (process) result (pdf_set) class(process_t), intent(in) :: process integer :: pdf_set end function process_get_pdf_set <>= module function process_get_pdf_set (process) result (pdf_set) class(process_t), intent(in) :: process integer :: pdf_set pdf_set = process%beam_config%get_pdf_set () end function process_get_pdf_set @ %def process_get_pdf_set @ <>= procedure :: pcm_contains_pdfs => process_pcm_contains_pdfs <>= module function process_pcm_contains_pdfs (process) result (has_pdfs) logical :: has_pdfs class(process_t), intent(in) :: process end function process_pcm_contains_pdfs <>= module function process_pcm_contains_pdfs (process) result (has_pdfs) logical :: has_pdfs class(process_t), intent(in) :: process has_pdfs = process%pcm%has_pdfs end function process_pcm_contains_pdfs @ %def process_pcm_contains_pdfs @ Get the beam spectrum file currently in use, if any. <>= procedure :: get_beam_file => process_get_beam_file <>= module function process_get_beam_file (process) result (file) class(process_t), intent(in) :: process type(string_t) :: file end function process_get_beam_file <>= module function process_get_beam_file (process) result (file) class(process_t), intent(in) :: process type(string_t) :: file file = process%beam_config%get_beam_file () end function process_get_beam_file @ %def process_get_beam_file @ Pointer to the process variable list. <>= procedure :: get_var_list_ptr => process_get_var_list_ptr <>= module function process_get_var_list_ptr (process) result (ptr) class(process_t), intent(in), target :: process type(var_list_t), pointer :: ptr end function process_get_var_list_ptr <>= module function process_get_var_list_ptr (process) result (ptr) class(process_t), intent(in), target :: process type(var_list_t), pointer :: ptr ptr => process%env%get_var_list_ptr () end function process_get_var_list_ptr @ %def process_get_var_list_ptr @ Pointer to the common model. <>= procedure :: get_model_ptr => process_get_model_ptr <>= module function process_get_model_ptr (process) result (ptr) class(process_t), intent(in) :: process class(model_data_t), pointer :: ptr end function process_get_model_ptr <>= module function process_get_model_ptr (process) result (ptr) class(process_t), intent(in) :: process class(model_data_t), pointer :: ptr ptr => process%config%model end function process_get_model_ptr @ %def process_get_model_ptr @ Use the embedded RNG factory to spawn a new random-number generator instance. (This modifies the state of the factory.) <>= procedure :: make_rng => process_make_rng <>= module subroutine process_make_rng (process, rng) class(process_t), intent(inout) :: process class(rng_t), intent(out), allocatable :: rng end subroutine process_make_rng <>= module subroutine process_make_rng (process, rng) class(process_t), intent(inout) :: process class(rng_t), intent(out), allocatable :: rng if (allocated (process%rng_factory)) then call process%rng_factory%make (rng) else call msg_bug ("Process: make rng: factory not allocated") end if end subroutine process_make_rng @ %def process_make_rng @ \subsection{Compute an amplitude} Each process variant should allow for computing an amplitude value directly, without generating a process instance. The process component is selected by the index [[i]]. The term within the process component is selected by [[j]]. The momentum combination is transferred as the array [[p]]. The function sets the specific quantum state via the indices of a flavor [[f]], helicity [[h]], and color [[c]] combination. Each index refers to the list of flavor, helicity, and color states, respectively, as stored in the process data. Optionally, we may set factorization and renormalization scale. If unset, the partonic c.m.\ energy is inserted. The function checks arguments for validity. For invalid arguments (quantum states), we return zero. <>= procedure :: compute_amplitude => process_compute_amplitude <>= module function process_compute_amplitude (process, i_core, i, j, p, & f, h, c, fac_scale, ren_scale, alpha_qcd_forced) result (amp) class(process_t), intent(in), target :: process integer, intent(in) :: i_core integer, intent(in) :: i, j type(vector4_t), dimension(:), intent(in) :: p integer, intent(in) :: f, h, c real(default), intent(in), optional :: fac_scale, ren_scale real(default), intent(in), allocatable, optional :: alpha_qcd_forced complex(default) :: amp end function process_compute_amplitude <>= module function process_compute_amplitude (process, i_core, i, j, p, & f, h, c, fac_scale, ren_scale, alpha_qcd_forced) result (amp) class(process_t), intent(in), target :: process integer, intent(in) :: i_core integer, intent(in) :: i, j type(vector4_t), dimension(:), intent(in) :: p integer, intent(in) :: f, h, c real(default), intent(in), optional :: fac_scale, ren_scale real(default), intent(in), allocatable, optional :: alpha_qcd_forced real(default) :: fscale, rscale real(default), allocatable :: aqcd_forced complex(default) :: amp class(prc_core_t), pointer :: core amp = 0 if (0 < i .and. i <= process%meta%n_components) then if (process%component(i)%active) then associate (core => process%core_entry(i_core)%core) associate (data => core%data) if (size (p) == data%n_in + data%n_out & .and. 0 < f .and. f <= data%n_flv & .and. 0 < h .and. h <= data%n_hel & .and. 0 < c .and. c <= data%n_col) then if (present (fac_scale)) then fscale = fac_scale else fscale = sum (p(data%n_in+1:)) ** 1 end if if (present (ren_scale)) then rscale = ren_scale else rscale = fscale end if if (present (alpha_qcd_forced)) then if (allocated (alpha_qcd_forced)) & allocate (aqcd_forced, source = alpha_qcd_forced) end if amp = core%compute_amplitude (j, p, f, h, c, & fscale, rscale, aqcd_forced) end if end associate end associate else amp = 0 end if end if end function process_compute_amplitude @ %def process_compute_amplitude @ Sanity check for the process library. We abort the program if it has changed after process initialization. <>= procedure :: check_library_sanity => process_check_library_sanity <>= module subroutine process_check_library_sanity (process) class(process_t), intent(in) :: process end subroutine process_check_library_sanity <>= module subroutine process_check_library_sanity (process) class(process_t), intent(in) :: process call process%env%check_lib_sanity (process%meta) end subroutine process_check_library_sanity @ %def process_check_library_sanity @ Reset the association to a process library. <>= procedure :: reset_library_ptr => process_reset_library_ptr <>= module subroutine process_reset_library_ptr (process) class(process_t), intent(inout) :: process end subroutine process_reset_library_ptr <>= module subroutine process_reset_library_ptr (process) class(process_t), intent(inout) :: process call process%env%reset_lib_ptr () end subroutine process_reset_library_ptr @ %def process_reset_library_ptr @ <>= procedure :: set_counter_mci_entry => process_set_counter_mci_entry <>= module subroutine process_set_counter_mci_entry (process, i_mci, counter) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(process_counter_t), intent(in) :: counter end subroutine process_set_counter_mci_entry <>= module subroutine process_set_counter_mci_entry (process, i_mci, counter) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(process_counter_t), intent(in) :: counter process%mci_entry(i_mci)%counter = counter end subroutine process_set_counter_mci_entry @ %def process_set_counter_mci_entry @ This is for suppression of numerical noise in the integration results stored in the [[process_mci_entry]] type. As the error and efficiency enter the MD5 sum, we recompute it. <>= procedure :: pacify => process_pacify <>= module subroutine process_pacify (process, efficiency_reset, error_reset) class(process_t), intent(inout) :: process logical, intent(in), optional :: efficiency_reset, error_reset end subroutine process_pacify <>= module subroutine process_pacify (process, efficiency_reset, error_reset) class(process_t), intent(inout) :: process logical, intent(in), optional :: efficiency_reset, error_reset logical :: eff_reset, err_reset integer :: i eff_reset = .false. err_reset = .false. if (present (efficiency_reset)) eff_reset = efficiency_reset if (present (error_reset)) err_reset = error_reset if (allocated (process%mci_entry)) then do i = 1, size (process%mci_entry) call process%mci_entry(i)%results%pacify (efficiency_reset) if (allocated (process%mci_entry(i)%mci)) then associate (mci => process%mci_entry(i)%mci) if (process%mci_entry(i)%mci%error_known & .and. err_reset) & mci%error = 0 if (process%mci_entry(i)%mci%efficiency_known & .and. eff_reset) & mci%efficiency = 1 call mci%pacify (efficiency_reset, error_reset) call mci%compute_md5sum () end associate end if end do end if end subroutine process_pacify @ %def process_pacify @ The following methods are used only in the unit tests; the access process internals directly that would otherwise be hidden. <>= procedure :: test_allocate_sf_channels procedure :: test_set_component_sf_channel procedure :: test_get_mci_ptr <>= module subroutine test_allocate_sf_channels (process, n) class(process_t), intent(inout) :: process integer, intent(in) :: n end subroutine test_allocate_sf_channels module subroutine test_set_component_sf_channel (process, c) class(process_t), intent(inout) :: process integer, dimension(:), intent(in) :: c end subroutine test_set_component_sf_channel module subroutine test_get_mci_ptr (process, mci) class(process_t), intent(in), target :: process class(mci_t), intent(out), pointer :: mci end subroutine test_get_mci_ptr <>= module subroutine test_allocate_sf_channels (process, n) class(process_t), intent(inout) :: process integer, intent(in) :: n call process%beam_config%allocate_sf_channels (n) end subroutine test_allocate_sf_channels module subroutine test_set_component_sf_channel (process, c) class(process_t), intent(inout) :: process integer, dimension(:), intent(in) :: c call process%component(1)%phs_config%set_sf_channel (c) end subroutine test_set_component_sf_channel module subroutine test_get_mci_ptr (process, mci) class(process_t), intent(in), target :: process class(mci_t), intent(out), pointer :: mci mci => process%mci_entry(1)%mci end subroutine test_get_mci_ptr @ %def test_allocate_sf_channels @ %def test_set_component_sf_channel @ %def test_get_mci_ptr @ <>= procedure :: init_mci_work => process_init_mci_work <>= module subroutine process_init_mci_work (process, mci_work, i) class(process_t), intent(in), target :: process type(mci_work_t), intent(out) :: mci_work integer, intent(in) :: i end subroutine process_init_mci_work <>= module subroutine process_init_mci_work (process, mci_work, i) class(process_t), intent(in), target :: process type(mci_work_t), intent(out) :: mci_work integer, intent(in) :: i call mci_work%init (process%mci_entry(i)) end subroutine process_init_mci_work @ %def process_init_mci_work @ Prepare the process core with type [[test_me]], or otherwise the externally provided [[type_string]] version. The toy dispatchers as a procedure argument come handy, knowing that we need to support only the [[test_me]] and [[template]] matrix-element types. Gfortran 7/8/9 bug, has to remain in the main module: <>= procedure :: setup_test_cores => process_setup_test_cores <>= subroutine dispatch_test_me_core (core, core_def, model, & helicity_selection, qcd, use_color_factors, has_beam_pol) use prc_test_core, only: test_t class(prc_core_t), allocatable, intent(inout) :: core class(prc_core_def_t), intent(in) :: core_def class(model_data_t), intent(in), target, optional :: model type(helicity_selection_t), intent(in), optional :: helicity_selection type(qcd_t), intent(in), optional :: qcd logical, intent(in), optional :: use_color_factors logical, intent(in), optional :: has_beam_pol allocate (test_t :: core) end subroutine dispatch_test_me_core subroutine dispatch_template_core (core, core_def, model, & helicity_selection, qcd, use_color_factors, has_beam_pol) use prc_template_me, only: prc_template_me_t class(prc_core_t), allocatable, intent(inout) :: core class(prc_core_def_t), intent(in) :: core_def class(model_data_t), intent(in), target, optional :: model type(helicity_selection_t), intent(in), optional :: helicity_selection type(qcd_t), intent(in), optional :: qcd logical, intent(in), optional :: use_color_factors logical, intent(in), optional :: has_beam_pol allocate (prc_template_me_t :: core) select type (core) type is (prc_template_me_t) call core%set_parameters (model) end select end subroutine dispatch_template_core subroutine process_setup_test_cores (process, type_string) class(process_t), intent(inout) :: process class(prc_core_t), allocatable :: core type(string_t), intent(in), optional :: type_string if (present (type_string)) then select case (char (type_string)) case ("template") call process%setup_cores (dispatch_template_core) case ("test_me") call process%setup_cores (dispatch_test_me_core) case default call msg_bug ("process setup test cores: unsupported type string") end select else call process%setup_cores (dispatch_test_me_core) end if end subroutine process_setup_test_cores @ %def process_setup_test_cores @ <>= procedure :: get_connected_states => process_get_connected_states <>= module function process_get_connected_states (process, i_component, & connected_terms) result (connected) type(connected_state_t), dimension(:), allocatable :: connected class(process_t), intent(in) :: process integer, intent(in) :: i_component type(connected_state_t), dimension(:), intent(in) :: connected_terms end function process_get_connected_states <>= module function process_get_connected_states (process, i_component, & connected_terms) result (connected) type(connected_state_t), dimension(:), allocatable :: connected class(process_t), intent(in) :: process integer, intent(in) :: i_component type(connected_state_t), dimension(:), intent(in) :: connected_terms integer :: i, i_conn integer :: n_conn n_conn = 0 do i = 1, process%get_n_terms () if (process%term(i)%i_component == i_component) then n_conn = n_conn + 1 end if end do allocate (connected (n_conn)) i_conn = 1 do i = 1, process%get_n_terms () if (process%term(i)%i_component == i_component) then connected (i_conn) = connected_terms(i) i_conn = i_conn + 1 end if end do end function process_get_connected_states @ %def process_get_connected_states @ \subsection{NLO specifics} These subroutines (and the NLO specific properties they work on) could potentially be moved to [[pcm_nlo_t]] and used more generically in [[process_t]] with an appropriate interface in [[pcm_t]] TODO wk 2018: This is used only by event initialization, which deals with an incomplete process object. <>= procedure :: init_nlo_settings => process_init_nlo_settings <>= module subroutine process_init_nlo_settings (process, var_list) class(process_t), intent(inout) :: process type(var_list_t), intent(in), target :: var_list end subroutine process_init_nlo_settings <>= module subroutine process_init_nlo_settings (process, var_list) class(process_t), intent(inout) :: process type(var_list_t), intent(in), target :: var_list select type (pcm => process%pcm) type is (pcm_nlo_t) call pcm%init_nlo_settings (var_list) if (debug_active (D_SUBTRACTION) .or. debug_active (D_VIRTUAL)) & call pcm%settings%write () class default call msg_fatal ("Attempt to set nlo_settings with a non-NLO pcm!") end select end subroutine process_init_nlo_settings @ %def process_init_nlo_settings @ <>= generic :: get_nlo_type_component => get_nlo_type_component_single procedure :: get_nlo_type_component_single => & process_get_nlo_type_component_single <>= elemental module function process_get_nlo_type_component_single & (process, i_component) result (val) integer :: val class(process_t), intent(in) :: process integer, intent(in) :: i_component end function process_get_nlo_type_component_single <>= elemental module function process_get_nlo_type_component_single & (process, i_component) result (val) integer :: val class(process_t), intent(in) :: process integer, intent(in) :: i_component val = process%component(i_component)%get_nlo_type () end function process_get_nlo_type_component_single @ %def process_get_nlo_type_component_single @ <>= generic :: get_nlo_type_component => get_nlo_type_component_all procedure :: get_nlo_type_component_all => process_get_nlo_type_component_all <>= pure module function process_get_nlo_type_component_all & (process) result (val) integer, dimension(:), allocatable :: val class(process_t), intent(in) :: process end function process_get_nlo_type_component_all <>= pure module function process_get_nlo_type_component_all (process) result (val) integer, dimension(:), allocatable :: val class(process_t), intent(in) :: process allocate (val (size (process%component))) val = process%component%get_nlo_type () end function process_get_nlo_type_component_all @ %def process_get_nlo_type_component_all @ <>= procedure :: is_nlo_calculation => process_is_nlo_calculation <>= module function process_is_nlo_calculation (process) result (nlo) logical :: nlo class(process_t), intent(in) :: process end function process_is_nlo_calculation <>= module function process_is_nlo_calculation (process) result (nlo) logical :: nlo class(process_t), intent(in) :: process select type (pcm => process%pcm) type is (pcm_nlo_t) nlo = .true. class default nlo = .false. end select end function process_is_nlo_calculation @ %def process_is_nlo_calculation @ <>= procedure :: get_negative_sf => process_get_negative_sf <>= module function process_get_negative_sf (process) result (neg_sf) logical :: neg_sf class(process_t), intent(in) :: process end function process_get_negative_sf <>= module function process_get_negative_sf (process) result (neg_sf) logical :: neg_sf class(process_t), intent(in) :: process neg_sf = process%config%process_def%get_negative_sf () end function process_get_negative_sf @ %def process_get_negative_sf @ <>= procedure :: is_combined_nlo_integration & => process_is_combined_nlo_integration <>= module function process_is_combined_nlo_integration & (process) result (combined) logical :: combined class(process_t), intent(in) :: process end function process_is_combined_nlo_integration <>= module function process_is_combined_nlo_integration & (process) result (combined) logical :: combined class(process_t), intent(in) :: process select type (pcm => process%pcm) type is (pcm_nlo_t) combined = pcm%settings%combined_integration class default combined = .false. end select end function process_is_combined_nlo_integration @ %def process_is_combined_nlo_integration @ <>= procedure :: component_is_real_finite => process_component_is_real_finite <>= pure module function process_component_is_real_finite & (process, i_component) result (val) logical :: val class(process_t), intent(in) :: process integer, intent(in) :: i_component end function process_component_is_real_finite <>= pure module function process_component_is_real_finite & (process, i_component) result (val) logical :: val class(process_t), intent(in) :: process integer, intent(in) :: i_component val = process%component(i_component)%component_type == COMP_REAL_FIN end function process_component_is_real_finite @ %def process_component_is_real_finite @ Return nlo data of a process component <>= procedure :: get_component_nlo_type => process_get_component_nlo_type <>= elemental module function process_get_component_nlo_type & (process, i_component) result (nlo_type) integer :: nlo_type class(process_t), intent(in) :: process integer, intent(in) :: i_component end function process_get_component_nlo_type <>= elemental module function process_get_component_nlo_type & (process, i_component) result (nlo_type) integer :: nlo_type class(process_t), intent(in) :: process integer, intent(in) :: i_component nlo_type = process%component(i_component)%config%get_nlo_type () end function process_get_component_nlo_type @ %def process_get_component_nlo_type @ Return a pointer to the core that belongs to a component. <>= procedure :: get_component_core_ptr => process_get_component_core_ptr <>= module function process_get_component_core_ptr & (process, i_component) result (core) class(process_t), intent(in), target :: process integer, intent(in) :: i_component class(prc_core_t), pointer :: core end function process_get_component_core_ptr <>= module function process_get_component_core_ptr & (process, i_component) result (core) class(process_t), intent(in), target :: process integer, intent(in) :: i_component class(prc_core_t), pointer :: core integer :: i_core i_core = process%pcm%get_i_core(i_component) core => process%core_entry(i_core)%core end function process_get_component_core_ptr @ %def process_get_component_core_ptr @ <>= procedure :: get_component_associated_born & => process_get_component_associated_born <>= module function process_get_component_associated_born & (process, i_component) result (i_born) class(process_t), intent(in) :: process integer, intent(in) :: i_component integer :: i_born end function process_get_component_associated_born <>= module function process_get_component_associated_born & (process, i_component) result (i_born) class(process_t), intent(in) :: process integer, intent(in) :: i_component integer :: i_born i_born = process%component(i_component)%config%get_associated_born () end function process_get_component_associated_born @ %def process_get_component_associated_born @ <>= procedure :: get_first_real_component => process_get_first_real_component <>= module function process_get_first_real_component (process) result (i_real) integer :: i_real class(process_t), intent(in) :: process end function process_get_first_real_component <>= module function process_get_first_real_component (process) result (i_real) integer :: i_real class(process_t), intent(in) :: process i_real = process%component(1)%config%get_associated_real () end function process_get_first_real_component @ %def process_get_first_real_component @ <>= procedure :: get_first_real_term => process_get_first_real_term <>= module function process_get_first_real_term (process) result (i_real) integer :: i_real class(process_t), intent(in) :: process integer :: i_component, i_term end function process_get_first_real_term <>= module function process_get_first_real_term (process) result (i_real) integer :: i_real class(process_t), intent(in) :: process integer :: i_component, i_term i_component = process%component(1)%config%get_associated_real () i_real = 0 do i_term = 1, size (process%term) if (process%term(i_term)%i_component == i_component) then i_real = i_term exit end if end do if (i_real == 0) call msg_fatal ("Did not find associated real term!") end function process_get_first_real_term @ %def process_get_first_real_term @ <>= procedure :: get_associated_real_fin => process_get_associated_real_fin <>= elemental module function process_get_associated_real_fin & (process, i_component) result (i_real) integer :: i_real class(process_t), intent(in) :: process integer, intent(in) :: i_component end function process_get_associated_real_fin <>= elemental module function process_get_associated_real_fin & (process, i_component) result (i_real) integer :: i_real class(process_t), intent(in) :: process integer, intent(in) :: i_component i_real = process%component(i_component)%config%get_associated_real_fin () end function process_get_associated_real_fin @ %def process_get_associated_real_fin @ <>= procedure :: select_i_term => process_select_i_term <>= pure module function process_select_i_term (process, i_mci) result (i_term) integer :: i_term class(process_t), intent(in) :: process integer, intent(in) :: i_mci end function process_select_i_term <>= pure module function process_select_i_term (process, i_mci) result (i_term) integer :: i_term class(process_t), intent(in) :: process integer, intent(in) :: i_mci integer :: i_component, i_sub i_component = process%mci_entry(i_mci)%i_component(1) i_term = process%component(i_component)%i_term(1) i_sub = process%term(i_term)%i_sub if (i_sub > 0) & i_term = process%term(i_sub)%i_term_global end function process_select_i_term @ %def process_select_i_term @ Would be better to do this at the level of the writer of the core but one has to bring NLO information there. <>= procedure :: prepare_any_external_code & => process_prepare_any_external_code <>= module subroutine process_prepare_any_external_code (process) class(process_t), intent(inout), target :: process end subroutine process_prepare_any_external_code <>= module subroutine process_prepare_any_external_code (process) class(process_t), intent(inout), target :: process integer :: i if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, & "process_prepare_external_code") associate (pcm => process%pcm) do i = 1, pcm%n_cores call pcm%prepare_any_external_code ( & process%core_entry(i), i, & process%get_library_name (), & process%config%model, & process%env%get_var_list_ptr ()) end do end associate end subroutine process_prepare_any_external_code @ %def process_prepare_any_external_code @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process config} <<[[process_config.f90]]>>= <> module process_config <> <> use os_interface use sf_base use sf_mappings use mappings, only: mapping_defaults_t use phs_forests, only: phs_parameters_t use sm_qcd use integration_results use flavors use interactions use model_data use models use process_libraries use process_constants use prc_core use beams use mci_base use beam_structures use dispatch_beams, only: dispatch_qcd use phs_base use expr_base use variables <> <> <> <> interface <> end interface contains <> end module process_config @ %def process_config @ <<[[process_config_sub.f90]]>>= <> submodule (process_config) process_config_s use format_utils, only: write_separator use io_units use diagnostics use md5 use physics_defs use helicities use colors use quantum_numbers use state_matrices use prc_external use prc_openloops, only: prc_openloops_t use prc_threshold, only: prc_threshold_t use blha_olp_interfaces, only: prc_blha_t implicit none contains <> end submodule process_config_s @ %def process_config_s @ Identifiers for the NLO setup. <>= integer, parameter, public :: COMP_DEFAULT = 0 integer, parameter, public :: COMP_REAL_FIN = 1 integer, parameter, public :: COMP_MASTER = 2 integer, parameter, public :: COMP_VIRT = 3 integer, parameter, public :: COMP_REAL = 4 integer, parameter, public :: COMP_REAL_SING = 5 integer, parameter, public :: COMP_MISMATCH = 6 integer, parameter, public :: COMP_PDF = 7 integer, parameter, public :: COMP_SUB = 8 integer, parameter, public :: COMP_RESUM = 9 @ \subsection{Output selection flags} We declare a number of identifiers for write methods, so they only displays selected parts. The identifiers can be supplied to the [[vlist]] array argument of the standard F2008 derived-type writer call. <>= integer, parameter, public :: F_PACIFY = 1 integer, parameter, public :: F_SHOW_VAR_LIST = 11 integer, parameter, public :: F_SHOW_EXPRESSIONS = 12 integer, parameter, public :: F_SHOW_LIB = 13 integer, parameter, public :: F_SHOW_MODEL = 14 integer, parameter, public :: F_SHOW_QCD = 15 integer, parameter, public :: F_SHOW_OS_DATA = 16 integer, parameter, public :: F_SHOW_RNG = 17 integer, parameter, public :: F_SHOW_BEAMS = 18 @ %def SHOW_VAR_LIST @ %def SHOW_EXPRESSIONS @ This is a simple function that returns true if a flag value is present in [[v_list]], but not its negative. If neither is present, it returns [[default]]. <>= public :: flagged <>= module function flagged (v_list, id, def) result (flag) logical :: flag integer, dimension(:), intent(in) :: v_list integer, intent(in) :: id logical, intent(in), optional :: def end function flagged <>= module function flagged (v_list, id, def) result (flag) logical :: flag integer, dimension(:), intent(in) :: v_list integer, intent(in) :: id logical, intent(in), optional :: def logical :: default_result default_result = .false.; if (present (def)) default_result = def if (default_result) then flag = all (v_list /= -id) else flag = all (v_list /= -id) .and. any (v_list == id) end if end function flagged @ %def flagged @ Related: if flag is set (unset), append [[value]] (its negative) to the [[v_list]], respectively. [[v_list]] must be allocated. <>= public :: set_flag <>= module subroutine set_flag (v_list, value, flag) integer, dimension(:), intent(inout), allocatable :: v_list integer, intent(in) :: value logical, intent(in), optional :: flag end subroutine set_flag <>= module subroutine set_flag (v_list, value, flag) integer, dimension(:), intent(inout), allocatable :: v_list integer, intent(in) :: value logical, intent(in), optional :: flag if (present (flag)) then if (flag) then v_list = [v_list, value] else v_list = [v_list, -value] end if end if end subroutine set_flag @ %def set_flag @ \subsection{Generic configuration data} This information concerns physical and technical properties of the process. It is fixed upon initialization, using data from the process specification and the variable list. The number [[n_in]] is the number of incoming beam particles, simultaneously the number of incoming partons, 1 for a decay and 2 for a scattering process. (The number of outgoing partons may depend on the process component.) The number [[n_components]] is the number of components that constitute the current process. The number [[n_terms]] is the number of distinct contributions to the scattering matrix that constitute the current process. Each component may generate several terms. The number [[n_mci]] is the number of independent MC integration configurations that this process uses. Distinct process components that share a MCI configuration may be combined pointwise. (Nevertheless, a given MC variable set may correspond to several ``nearby'' kinematical configurations.) This is also the number of distinct sampling-function results that this process can generate. Process components that use distinct variable sets are added only once after an integration pass has completed. The [[model]] pointer identifies the physics model and its parameters. This is a pointer to an external object. Various [[parse_node_t]] objects are taken from the SINDARIN input. They encode expressions for evaluating cuts and scales. The workspaces for evaluating those expressions are set up in the [[effective_state]] subobjects. Note that these are really pointers, so the actual nodes are not stored inside the process object. The [[md5sum]] is taken and used to verify the process configuration when re-reading data from file. <>= public :: process_config_data_t <>= type :: process_config_data_t class(process_def_t), pointer :: process_def => null () integer :: n_in = 0 integer :: n_components = 0 integer :: n_terms = 0 integer :: n_mci = 0 type(string_t) :: model_name class(model_data_t), pointer :: model => null () type(qcd_t) :: qcd class(expr_factory_t), allocatable :: ef_cuts class(expr_factory_t), allocatable :: ef_scale class(expr_factory_t), allocatable :: ef_fac_scale class(expr_factory_t), allocatable :: ef_ren_scale class(expr_factory_t), allocatable :: ef_weight character(32) :: md5sum = "" contains <> end type process_config_data_t @ %def process_config_data_t @ Here, we may compress the expressions for cuts etc. <>= procedure :: write => process_config_data_write <>= module subroutine process_config_data_write & (config, u, counters, model, expressions) class(process_config_data_t), intent(in) :: config integer, intent(in) :: u logical, intent(in) :: counters logical, intent(in) :: model logical, intent(in) :: expressions end subroutine process_config_data_write <>= module subroutine process_config_data_write & (config, u, counters, model, expressions) class(process_config_data_t), intent(in) :: config integer, intent(in) :: u logical, intent(in) :: counters logical, intent(in) :: model logical, intent(in) :: expressions write (u, "(1x,A)") "Configuration data:" if (counters) then write (u, "(3x,A,I0)") "Number of incoming particles = ", & config%n_in write (u, "(3x,A,I0)") "Number of process components = ", & config%n_components write (u, "(3x,A,I0)") "Number of process terms = ", & config%n_terms write (u, "(3x,A,I0)") "Number of MCI configurations = ", & config%n_mci end if if (associated (config%model)) then write (u, "(3x,A,A)") "Model = ", char (config%model_name) if (model) then call write_separator (u) call config%model%write (u) call write_separator (u) end if else write (u, "(3x,A,A,A)") "Model = ", char (config%model_name), & " [not associated]" end if call config%qcd%write (u, show_md5sum = .false.) call write_separator (u) if (expressions) then if (allocated (config%ef_cuts)) then call write_separator (u) write (u, "(3x,A)") "Cut expression:" call config%ef_cuts%write (u) end if if (allocated (config%ef_scale)) then call write_separator (u) write (u, "(3x,A)") "Scale expression:" call config%ef_scale%write (u) end if if (allocated (config%ef_fac_scale)) then call write_separator (u) write (u, "(3x,A)") "Factorization scale expression:" call config%ef_fac_scale%write (u) end if if (allocated (config%ef_ren_scale)) then call write_separator (u) write (u, "(3x,A)") "Renormalization scale expression:" call config%ef_ren_scale%write (u) end if if (allocated (config%ef_weight)) then call write_separator (u) write (u, "(3x,A)") "Weight expression:" call config%ef_weight%write (u) end if else call write_separator (u) write (u, "(3x,A)") "Expressions (cut, scales, weight): [not shown]" end if if (config%md5sum /= "") then call write_separator (u) write (u, "(3x,A,A,A)") "MD5 sum (config) = '", config%md5sum, "'" end if end subroutine process_config_data_write @ %def process_config_data_write @ Initialize. We use information from the process metadata and from the process library, given the process ID. We also store the currently active OS data set. The model pointer references the model data within the [[env]] record. That should be an instance of the global model. We initialize the QCD object, unless the environment information is unavailable (unit tests). The RNG factory object is imported by moving the allocation. Gfortran 7/8/9 bug: has to remain in the main module: <>= procedure :: init => process_config_data_init <>= subroutine process_config_data_init (config, meta, env) class(process_config_data_t), intent(out) :: config type(process_metadata_t), intent(in) :: meta type(process_environment_t), intent(in) :: env config%process_def => env%lib%get_process_def_ptr (meta%id) config%n_in = config%process_def%get_n_in () config%n_components = size (meta%component_id) config%model => env%get_model_ptr () config%model_name = config%model%get_name () if (env%got_var_list ()) then call dispatch_qcd & (config%qcd, env%get_var_list_ptr (), env%get_os_data ()) end if end subroutine process_config_data_init @ %def process_config_data_init @ Current implementation: nothing to finalize. <>= procedure :: final => process_config_data_final <>= module subroutine process_config_data_final (config) class(process_config_data_t), intent(inout) :: config end subroutine process_config_data_final <>= module subroutine process_config_data_final (config) class(process_config_data_t), intent(inout) :: config end subroutine process_config_data_final @ %def process_config_data_final @ Return a copy of the QCD data block. <>= procedure :: get_qcd => process_config_data_get_qcd <>= module function process_config_data_get_qcd (config) result (qcd) class(process_config_data_t), intent(in) :: config type(qcd_t) :: qcd end function process_config_data_get_qcd <>= module function process_config_data_get_qcd (config) result (qcd) class(process_config_data_t), intent(in) :: config type(qcd_t) :: qcd qcd = config%qcd end function process_config_data_get_qcd @ %def process_config_data_get_qcd @ Compute the MD5 sum of the configuration data. This encodes, in particular, the model and the expressions for cut, scales, weight, etc. It should not contain the IDs and number of components, etc., since the MD5 sum should be useful for integrating individual components. This is done only once. If the MD5 sum is nonempty, the calculation is skipped. <>= procedure :: compute_md5sum => process_config_data_compute_md5sum <>= module subroutine process_config_data_compute_md5sum (config) class(process_config_data_t), intent(inout) :: config end subroutine process_config_data_compute_md5sum <>= module subroutine process_config_data_compute_md5sum (config) class(process_config_data_t), intent(inout) :: config integer :: u if (config%md5sum == "") then u = free_unit () open (u, status = "scratch", action = "readwrite") call config%write (u, counters = .false., & model = .true., expressions = .true.) rewind (u) config%md5sum = md5sum (u) close (u) end if end subroutine process_config_data_compute_md5sum @ %def process_config_data_compute_md5sum @ <>= procedure :: get_md5sum => process_config_data_get_md5sum <>= pure module function process_config_data_get_md5sum (config) result (md5) character(32) :: md5 class(process_config_data_t), intent(in) :: config end function process_config_data_get_md5sum <>= pure module function process_config_data_get_md5sum (config) result (md5) character(32) :: md5 class(process_config_data_t), intent(in) :: config md5 = config%md5sum end function process_config_data_get_md5sum @ %def process_config_data_get_md5sum @ \subsection{Environment} This record stores a snapshot of the process environment at the point where the process object is created. Model and variable list are implemented as pointer, so they always have the [[target]] attribute. For unit-testing purposes, setting the var list is optional. If not set, the pointer is null. <>= public :: process_environment_t <>= type :: process_environment_t private type(model_t), pointer :: model => null () type(var_list_t), pointer :: var_list => null () logical :: var_list_is_set = .false. type(process_library_t), pointer :: lib => null () type(beam_structure_t) :: beam_structure type(os_data_t) :: os_data contains <> end type process_environment_t @ %def process_environment_t @ Model and local var list are snapshots and need a finalizer. <>= procedure :: final => process_environment_final <>= module subroutine process_environment_final (env) class(process_environment_t), intent(inout) :: env end subroutine process_environment_final <>= module subroutine process_environment_final (env) class(process_environment_t), intent(inout) :: env if (associated (env%model)) then call env%model%final () deallocate (env%model) end if if (associated (env%var_list)) then call env%var_list%final (follow_link=.true.) deallocate (env%var_list) end if end subroutine process_environment_final @ %def process_environment_final @ Output, DTIO compatible. <>= procedure :: write => process_environment_write procedure :: write_formatted => process_environment_write_formatted ! generic :: write (formatted) => write_formatted <>= module subroutine process_environment_write (env, unit, & show_var_list, show_model, show_lib, show_beams, show_os_data) class(process_environment_t), intent(in) :: env integer, intent(in), optional :: unit logical, intent(in), optional :: show_var_list logical, intent(in), optional :: show_model logical, intent(in), optional :: show_lib logical, intent(in), optional :: show_beams logical, intent(in), optional :: show_os_data end subroutine process_environment_write <>= module subroutine process_environment_write (env, unit, & show_var_list, show_model, show_lib, show_beams, show_os_data) class(process_environment_t), intent(in) :: env integer, intent(in), optional :: unit logical, intent(in), optional :: show_var_list logical, intent(in), optional :: show_model logical, intent(in), optional :: show_lib logical, intent(in), optional :: show_beams logical, intent(in), optional :: show_os_data integer :: u, iostat integer, dimension(:), allocatable :: v_list character(0) :: iomsg u = given_output_unit (unit) allocate (v_list (0)) call set_flag (v_list, F_SHOW_VAR_LIST, show_var_list) call set_flag (v_list, F_SHOW_MODEL, show_model) call set_flag (v_list, F_SHOW_LIB, show_lib) call set_flag (v_list, F_SHOW_BEAMS, show_beams) call set_flag (v_list, F_SHOW_OS_DATA, show_os_data) call env%write_formatted (u, "LISTDIRECTED", v_list, iostat, iomsg) end subroutine process_environment_write @ %def process_environment_write @ DTIO standard write. <>= module subroutine process_environment_write_formatted & (dtv, unit, iotype, v_list, iostat, iomsg) class(process_environment_t), intent(in) :: dtv integer, intent(in) :: unit character(*), intent(in) :: iotype integer, dimension(:), intent(in) :: v_list integer, intent(out) :: iostat character(*), intent(inout) :: iomsg end subroutine process_environment_write_formatted <>= module subroutine process_environment_write_formatted & (dtv, unit, iotype, v_list, iostat, iomsg) class(process_environment_t), intent(in) :: dtv integer, intent(in) :: unit character(*), intent(in) :: iotype integer, dimension(:), intent(in) :: v_list integer, intent(out) :: iostat character(*), intent(inout) :: iomsg associate (env => dtv) if (flagged (v_list, F_SHOW_VAR_LIST, .true.)) then write (unit, "(1x,A)") "Variable list:" if (associated (env%var_list)) then call write_separator (unit) call env%var_list%write (unit) else write (unit, "(3x,A)") "[not allocated]" end if call write_separator (unit) end if if (flagged (v_list, F_SHOW_MODEL, .true.)) then write (unit, "(1x,A)") "Model:" if (associated (env%model)) then call write_separator (unit) call env%model%write (unit) else write (unit, "(3x,A)") "[not allocated]" end if call write_separator (unit) end if if (flagged (v_list, F_SHOW_LIB, .true.)) then write (unit, "(1x,A)") "Process library:" if (associated (env%lib)) then call write_separator (unit) call env%lib%write (unit) else write (unit, "(3x,A)") "[not allocated]" end if end if if (flagged (v_list, F_SHOW_BEAMS, .true.)) then call write_separator (unit) call env%beam_structure%write (unit) end if if (flagged (v_list, F_SHOW_OS_DATA, .true.)) then write (unit, "(1x,A)") "Operating-system data:" call write_separator (unit) call env%os_data%write (unit) end if end associate iostat = 0 end subroutine process_environment_write_formatted @ %def process_environment_write_formatted @ Initialize: Make a snapshot of the provided model. Make a link to the current process library. Also make a snapshot of the variable list, if provided. If none is provided, there is an empty variable list nevertheless, so a pointer lookup does not return null. If no beam structure is provided, the beam-structure member is empty and will yield a number of zero beams when queried. <>= procedure :: init => process_environment_init <>= module subroutine process_environment_init & (env, model, lib, os_data, var_list, beam_structure) class(process_environment_t), intent(out) :: env type(model_t), intent(in), target :: model type(process_library_t), intent(in), target :: lib type(os_data_t), intent(in) :: os_data type(var_list_t), intent(in), target, optional :: var_list type(beam_structure_t), intent(in), optional :: beam_structure end subroutine process_environment_init <>= module subroutine process_environment_init & (env, model, lib, os_data, var_list, beam_structure) class(process_environment_t), intent(out) :: env type(model_t), intent(in), target :: model type(process_library_t), intent(in), target :: lib type(os_data_t), intent(in) :: os_data type(var_list_t), intent(in), target, optional :: var_list type(beam_structure_t), intent(in), optional :: beam_structure allocate (env%model) call env%model%init_instance (model) env%lib => lib env%os_data = os_data allocate (env%var_list) if (present (var_list)) then call env%var_list%init_snapshot (var_list, follow_link=.true.) env%var_list_is_set = .true. end if if (present (beam_structure)) then env%beam_structure = beam_structure end if end subroutine process_environment_init @ %def process_environment_init @ Indicate whether a variable list has been provided upon initialization. <>= procedure :: got_var_list => process_environment_got_var_list <>= module function process_environment_got_var_list (env) result (flag) class(process_environment_t), intent(in) :: env logical :: flag end function process_environment_got_var_list <>= module function process_environment_got_var_list (env) result (flag) class(process_environment_t), intent(in) :: env logical :: flag flag = env%var_list_is_set end function process_environment_got_var_list @ %def process_environment_got_var_list @ Return a pointer to the variable list. <>= procedure :: get_var_list_ptr => process_environment_get_var_list_ptr <>= module function process_environment_get_var_list_ptr (env) result (var_list) class(process_environment_t), intent(in) :: env type(var_list_t), pointer :: var_list end function process_environment_get_var_list_ptr <>= module function process_environment_get_var_list_ptr (env) result (var_list) class(process_environment_t), intent(in) :: env type(var_list_t), pointer :: var_list var_list => env%var_list end function process_environment_get_var_list_ptr @ %def process_environment_get_var_list_ptr @ Return a pointer to the model, if it exists. <>= procedure :: get_model_ptr => process_environment_get_model_ptr <>= module function process_environment_get_model_ptr (env) result (model) class(process_environment_t), intent(in) :: env type(model_t), pointer :: model end function process_environment_get_model_ptr <>= module function process_environment_get_model_ptr (env) result (model) class(process_environment_t), intent(in) :: env type(model_t), pointer :: model model => env%model end function process_environment_get_model_ptr @ %def process_environment_get_model_ptr @ Return the process library pointer. <>= procedure :: get_lib_ptr => process_environment_get_lib_ptr <>= module function process_environment_get_lib_ptr (env) result (lib) class(process_environment_t), intent(inout) :: env type(process_library_t), pointer :: lib end function process_environment_get_lib_ptr <>= module function process_environment_get_lib_ptr (env) result (lib) class(process_environment_t), intent(inout) :: env type(process_library_t), pointer :: lib lib => env%lib end function process_environment_get_lib_ptr @ %def process_environment_get_lib_ptr @ Clear the process library pointer, in case the library is deleted. <>= procedure :: reset_lib_ptr => process_environment_reset_lib_ptr <>= module subroutine process_environment_reset_lib_ptr (env) class(process_environment_t), intent(inout) :: env end subroutine process_environment_reset_lib_ptr <>= module subroutine process_environment_reset_lib_ptr (env) class(process_environment_t), intent(inout) :: env env%lib => null () end subroutine process_environment_reset_lib_ptr @ %def process_environment_reset_lib_ptr @ Check whether the process library has changed, in case the library is recompiled, etc. <>= procedure :: check_lib_sanity => process_environment_check_lib_sanity <>= module subroutine process_environment_check_lib_sanity (env, meta) class(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta end subroutine process_environment_check_lib_sanity <>= module subroutine process_environment_check_lib_sanity (env, meta) class(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta if (associated (env%lib)) then if (env%lib%get_update_counter () /= meta%lib_update_counter) then call msg_fatal ("Process '" // char (meta%id) & // "': library has been recompiled after integration") end if end if end subroutine process_environment_check_lib_sanity @ %def process_environment_check_lib_sanity @ Fill the [[data]] block using the appropriate process-library access entry. <>= procedure :: fill_process_constants => & process_environment_fill_process_constants <>= module subroutine process_environment_fill_process_constants & (env, id, i_component, data) class(process_environment_t), intent(in) :: env type(string_t), intent(in) :: id integer, intent(in) :: i_component type(process_constants_t), intent(out) :: data end subroutine process_environment_fill_process_constants <>= module subroutine process_environment_fill_process_constants & (env, id, i_component, data) class(process_environment_t), intent(in) :: env type(string_t), intent(in) :: id integer, intent(in) :: i_component type(process_constants_t), intent(out) :: data call env%lib%fill_constants (id, i_component, data) end subroutine process_environment_fill_process_constants @ %def process_environment_fill_process_constants @ Return the entire beam structure. <>= procedure :: get_beam_structure => process_environment_get_beam_structure <>= module function process_environment_get_beam_structure & (env) result (beam_structure) class(process_environment_t), intent(in) :: env type(beam_structure_t) :: beam_structure end function process_environment_get_beam_structure <>= module function process_environment_get_beam_structure & (env) result (beam_structure) class(process_environment_t), intent(in) :: env type(beam_structure_t) :: beam_structure beam_structure = env%beam_structure end function process_environment_get_beam_structure @ %def process_environment_get_beam_structure @ Check the beam structure for PDFs. <>= procedure :: has_pdfs => process_environment_has_pdfs <>= module function process_environment_has_pdfs (env) result (flag) class(process_environment_t), intent(in) :: env logical :: flag end function process_environment_has_pdfs <>= module function process_environment_has_pdfs (env) result (flag) class(process_environment_t), intent(in) :: env logical :: flag flag = env%beam_structure%has_pdf () end function process_environment_has_pdfs @ %def process_environment_has_pdfs @ Check the beam structure for polarized beams. <>= procedure :: has_polarized_beams => process_environment_has_polarized_beams <>= module function process_environment_has_polarized_beams (env) result (flag) class(process_environment_t), intent(in) :: env logical :: flag end function process_environment_has_polarized_beams <>= module function process_environment_has_polarized_beams (env) result (flag) class(process_environment_t), intent(in) :: env logical :: flag flag = env%beam_structure%has_polarized_beams () end function process_environment_has_polarized_beams @ %def process_environment_has_polarized_beams @ Return a copy of the OS data block. <>= procedure :: get_os_data => process_environment_get_os_data <>= module function process_environment_get_os_data (env) result (os_data) class(process_environment_t), intent(in) :: env type(os_data_t) :: os_data end function process_environment_get_os_data <>= module function process_environment_get_os_data (env) result (os_data) class(process_environment_t), intent(in) :: env type(os_data_t) :: os_data os_data = env%os_data end function process_environment_get_os_data @ %def process_environment_get_os_data @ \subsection{Metadata} This information describes the process. It is fixed upon initialization. The [[id]] string is the name of the process object, as given by the user. The matrix element generator will use this string for naming Fortran procedures and types, so it should qualify as a Fortran name. The [[num_id]] is meaningful if nonzero. It is used for communication with external programs or file standards which do not support string IDs. The [[run_id]] string distinguishes among several runs for the same process. It identifies process instances with respect to adapted integration grids and similar run-specific data. The run ID is kept when copying processes for creating instances, however, so it does not distinguish event samples. The [[lib_name]] identifies the process library where the process definition and the process driver are located. The [[lib_index]] is the index of entry in the process library that corresponds to the current process. The [[component_id]] array identifies the individual process components. The [[component_description]] is an array of human-readable strings that characterize the process components, for instance [[a, b => c, d]]. The [[active]] mask array marks those components which are active. The others are skipped. <>= public :: process_metadata_t <>= type :: process_metadata_t integer :: type = PRC_UNKNOWN type(string_t) :: id integer :: num_id = 0 type(string_t) :: run_id type(string_t), allocatable :: lib_name integer :: lib_update_counter = 0 integer :: lib_index = 0 integer :: n_components = 0 type(string_t), dimension(:), allocatable :: component_id type(string_t), dimension(:), allocatable :: component_description logical, dimension(:), allocatable :: active contains <> end type process_metadata_t @ %def process_metadata_t @ Output: ID and run ID. We write the variable list only upon request. <>= procedure :: write => process_metadata_write <>= module subroutine process_metadata_write (meta, u, screen) class(process_metadata_t), intent(in) :: meta integer, intent(in) :: u logical, intent(in) :: screen end subroutine process_metadata_write <>= module subroutine process_metadata_write (meta, u, screen) class(process_metadata_t), intent(in) :: meta integer, intent(in) :: u logical, intent(in) :: screen integer :: i select case (meta%type) case (PRC_UNKNOWN) if (screen) then write (msg_buffer, "(A)") "Process [undefined]" else write (u, "(1x,A)") "Process [undefined]" end if return case (PRC_DECAY) if (screen) then write (msg_buffer, "(A,1x,A,A,A)") "Process [decay]:", & "'", char (meta%id), "'" else write (u, "(1x,A)", advance="no") "Process [decay]:" end if case (PRC_SCATTERING) if (screen) then write (msg_buffer, "(A,1x,A,A,A)") "Process [scattering]:", & "'", char (meta%id), "'" else write (u, "(1x,A)", advance="no") "Process [scattering]:" end if case default call msg_bug ("process_write: undefined process type") end select if (screen) then call msg_message () else write (u, "(1x,A,A,A)") "'", char (meta%id), "'" end if if (meta%num_id /= 0) then if (screen) then write (msg_buffer, "(2x,A,I0)") "ID (num) = ", meta%num_id call msg_message () else write (u, "(3x,A,I0)") "ID (num) = ", meta%num_id end if end if if (screen) then if (meta%run_id /= "") then write (msg_buffer, "(2x,A,A,A)") "Run ID = '", & char (meta%run_id), "'" call msg_message () end if else write (u, "(3x,A,A,A)") "Run ID = '", char (meta%run_id), "'" end if if (allocated (meta%lib_name)) then if (screen) then write (msg_buffer, "(2x,A,A,A)") "Library name = '", & char (meta%lib_name), "'" call msg_message () else write (u, "(3x,A,A,A)") "Library name = '", & char (meta%lib_name), "'" end if else if (screen) then write (msg_buffer, "(2x,A)") "Library name = [not associated]" call msg_message () else write (u, "(3x,A)") "Library name = [not associated]" end if end if if (screen) then write (msg_buffer, "(2x,A,I0)") "Process index = ", meta%lib_index call msg_message () else write (u, "(3x,A,I0)") "Process index = ", meta%lib_index end if if (allocated (meta%component_id)) then if (screen) then if (any (meta%active)) then write (msg_buffer, "(2x,A)") "Process components:" else write (msg_buffer, "(2x,A)") "Process components: [none]" end if call msg_message () else write (u, "(3x,A)") "Process components:" end if do i = 1, size (meta%component_id) if (.not. meta%active(i)) cycle if (screen) then write (msg_buffer, "(4x,I0,9A)") i, ": '", & char (meta%component_id (i)), "': ", & char (meta%component_description (i)) call msg_message () else write (u, "(5x,I0,9A)") i, ": '", & char (meta%component_id (i)), "': ", & char (meta%component_description (i)) end if end do end if if (screen) then write (msg_buffer, "(A)") repeat ("-", 72) call msg_message () else call write_separator (u) end if end subroutine process_metadata_write @ %def process_metadata_write @ Short output: list components. <>= procedure :: show => process_metadata_show <>= module subroutine process_metadata_show (meta, u, model_name) class(process_metadata_t), intent(in) :: meta integer, intent(in) :: u type(string_t), intent(in) :: model_name end subroutine process_metadata_show <>= module subroutine process_metadata_show (meta, u, model_name) class(process_metadata_t), intent(in) :: meta integer, intent(in) :: u type(string_t), intent(in) :: model_name integer :: i select case (meta%type) case (PRC_UNKNOWN) write (u, "(A)") "Process: [undefined]" return case default write (u, "(A)", advance="no") "Process:" end select write (u, "(1x,A)", advance="no") char (meta%id) select case (meta%num_id) case (0) case default write (u, "(1x,'(',I0,')')", advance="no") meta%num_id end select select case (char (model_name)) case ("") case default write (u, "(1x,'[',A,']')", advance="no") char (model_name) end select write (u, *) if (allocated (meta%component_id)) then do i = 1, size (meta%component_id) if (meta%active(i)) then write (u, "(2x,I0,':',1x,A)") i, & char (meta%component_description (i)) end if end do end if end subroutine process_metadata_show @ %def process_metadata_show @ Initialize. Find process ID and run ID. Also find the process ID in the process library and retrieve some metadata from there. <>= procedure :: init => process_metadata_init <>= module subroutine process_metadata_init (meta, id, lib, var_list) class(process_metadata_t), intent(out) :: meta type(string_t), intent(in) :: id type(process_library_t), intent(in), target :: lib type(var_list_t), intent(in) :: var_list end subroutine process_metadata_init <>= module subroutine process_metadata_init (meta, id, lib, var_list) class(process_metadata_t), intent(out) :: meta type(string_t), intent(in) :: id type(process_library_t), intent(in), target :: lib type(var_list_t), intent(in) :: var_list select case (lib%get_n_in (id)) case (1); meta%type = PRC_DECAY case (2); meta%type = PRC_SCATTERING case default call msg_bug ("Process '" // char (id) // "': impossible n_in") end select meta%id = id meta%run_id = var_list%get_sval (var_str ("$run_id")) allocate (meta%lib_name) meta%lib_name = lib%get_name () meta%lib_update_counter = lib%get_update_counter () if (lib%contains (id)) then meta%lib_index = lib%get_entry_index (id) meta%num_id = lib%get_num_id (id) call lib%get_component_list (id, meta%component_id) meta%n_components = size (meta%component_id) call lib%get_component_description_list & (id, meta%component_description) allocate (meta%active (meta%n_components), source = .true.) else call msg_fatal ("Process library does not contain process '" & // char (id) // "'") end if if (.not. lib%is_active ()) then call msg_bug ("Process init: inactive library not handled yet") end if end subroutine process_metadata_init @ %def process_metadata_init @ Mark a component as inactive. <>= procedure :: deactivate_component => process_metadata_deactivate_component <>= module subroutine process_metadata_deactivate_component (meta, i) class(process_metadata_t), intent(inout) :: meta integer, intent(in) :: i end subroutine process_metadata_deactivate_component <>= module subroutine process_metadata_deactivate_component (meta, i) class(process_metadata_t), intent(inout) :: meta integer, intent(in) :: i call msg_message ("Process component '" & // char (meta%component_id(i)) // "': matrix element vanishes") meta%active(i) = .false. end subroutine process_metadata_deactivate_component @ %def process_metadata_deactivate_component @ \subsection{Phase-space configuration} A process can have a number of independent phase-space configuration entries, depending on the process definition and evaluation algorithm. Each entry holds various configuration-parameter data and the actual [[phs_config_t]] record, which can vary in concrete type. <>= public :: process_phs_config_t <>= type :: process_phs_config_t type(phs_parameters_t) :: phs_par type(mapping_defaults_t) :: mapping_defs class(phs_config_t), allocatable :: phs_config contains <> end type process_phs_config_t @ %def process_phs_config_t @ Output, DTIO compatible. <>= procedure :: write => process_phs_config_write procedure :: write_formatted => process_phs_config_write_formatted ! generic :: write (formatted) => write_formatted <>= module subroutine process_phs_config_write (phs_config, unit) class(process_phs_config_t), intent(in) :: phs_config integer, intent(in), optional :: unit end subroutine process_phs_config_write <>= module subroutine process_phs_config_write (phs_config, unit) class(process_phs_config_t), intent(in) :: phs_config integer, intent(in), optional :: unit integer :: u, iostat integer, dimension(:), allocatable :: v_list character(0) :: iomsg u = given_output_unit (unit) allocate (v_list (0)) call phs_config%write_formatted (u, "LISTDIRECTED", v_list, iostat, iomsg) end subroutine process_phs_config_write @ %def process_phs_config_write @ DTIO standard write. <>= module subroutine process_phs_config_write_formatted & (dtv, unit, iotype, v_list, iostat, iomsg) class(process_phs_config_t), intent(in) :: dtv integer, intent(in) :: unit character(*), intent(in) :: iotype integer, dimension(:), intent(in) :: v_list integer, intent(out) :: iostat character(*), intent(inout) :: iomsg end subroutine process_phs_config_write_formatted <>= module subroutine process_phs_config_write_formatted & (dtv, unit, iotype, v_list, iostat, iomsg) class(process_phs_config_t), intent(in) :: dtv integer, intent(in) :: unit character(*), intent(in) :: iotype integer, dimension(:), intent(in) :: v_list integer, intent(out) :: iostat character(*), intent(inout) :: iomsg associate (phs_config => dtv) write (unit, "(1x, A)") "Phase-space configuration entry:" call phs_config%phs_par%write (unit) call phs_config%mapping_defs%write (unit) end associate iostat = 0 end subroutine process_phs_config_write_formatted @ %def process_phs_config_write_formatted @ \subsection{Beam configuration} The object [[data]] holds all details about the initial beam configuration. The allocatable array [[sf]] holds the structure-function configuration blocks. There are [[n_strfun]] entries in the structure-function chain (not counting the initial beam object). We maintain [[n_channel]] independent parameterizations of this chain. If this is greater than zero, we need a multi-channel sampling algorithm, where for each point one channel is selected to generate kinematics. The number of parameters that are required for generating a structure-function chain is [[n_sfpar]]. The flag [[azimuthal_dependence]] tells whether the process setup is symmetric about the beam axis in the c.m.\ system. This implies that there is no transversal beam polarization. The flag [[lab_is_cm]] is obvious. <>= public :: process_beam_config_t <>= type :: process_beam_config_t type(beam_data_t) :: data integer :: n_strfun = 0 integer :: n_channel = 1 integer :: n_sfpar = 0 type(sf_config_t), dimension(:), allocatable :: sf type(sf_channel_t), dimension(:), allocatable :: sf_channel logical :: azimuthal_dependence = .false. logical :: lab_is_cm = .true. character(32) :: md5sum = "" logical :: sf_trace = .false. type(string_t) :: sf_trace_file contains <> end type process_beam_config_t @ %def process_beam_config_t @ Here we write beam data only if they are actually used. The [[verbose]] flag is passed to the beam-data writer. <>= procedure :: write => process_beam_config_write <>= module subroutine process_beam_config_write (object, unit, verbose) class(process_beam_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine process_beam_config_write <>= module subroutine process_beam_config_write (object, unit, verbose) class(process_beam_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i, c u = given_output_unit (unit) call object%data%write (u, verbose = verbose) if (object%data%initialized) then write (u, "(3x,A,L1)") "Azimuthal dependence = ", & object%azimuthal_dependence write (u, "(3x,A,L1)") "Lab frame is c.m. frame = ", & object%lab_is_cm if (object%md5sum /= "") then write (u, "(3x,A,A,A)") "MD5 sum (beams/strf) = '", & object%md5sum, "'" end if if (allocated (object%sf)) then do i = 1, size (object%sf) call object%sf(i)%write (u) end do if (any_sf_channel_has_mapping (object%sf_channel)) then write (u, "(1x,A,L1)") "Structure-function mappings per channel:" do c = 1, object%n_channel write (u, "(3x,I0,':')", advance="no") c call object%sf_channel(c)%write (u) end do end if end if end if end subroutine process_beam_config_write @ %def process_beam_config_write @ The beam data have a finalizer. We assume that there is none for the structure-function data. <>= procedure :: final => process_beam_config_final <>= module subroutine process_beam_config_final (object) class(process_beam_config_t), intent(inout) :: object end subroutine process_beam_config_final <>= module subroutine process_beam_config_final (object) class(process_beam_config_t), intent(inout) :: object call object%data%final () end subroutine process_beam_config_final @ %def process_beam_config_final @ Initialize the beam setup with a given beam structure object. <>= procedure :: init_beam_structure => process_beam_config_init_beam_structure <>= module subroutine process_beam_config_init_beam_structure & (beam_config, beam_structure, sqrts, model, decay_rest_frame) class(process_beam_config_t), intent(out) :: beam_config type(beam_structure_t), intent(in) :: beam_structure logical, intent(in), optional :: decay_rest_frame real(default), intent(in) :: sqrts class(model_data_t), intent(in), target :: model end subroutine process_beam_config_init_beam_structure <>= module subroutine process_beam_config_init_beam_structure & (beam_config, beam_structure, sqrts, model, decay_rest_frame) class(process_beam_config_t), intent(out) :: beam_config type(beam_structure_t), intent(in) :: beam_structure logical, intent(in), optional :: decay_rest_frame real(default), intent(in) :: sqrts class(model_data_t), intent(in), target :: model call beam_config%data%init_structure (beam_structure, & sqrts, model, decay_rest_frame) beam_config%lab_is_cm = beam_config%data%lab_is_cm end subroutine process_beam_config_init_beam_structure @ %def process_beam_config_init_beam_structure @ Initialize the beam setup for a scattering process with specified flavor combination, other properties taken from the beam structure object (if any). <>= procedure :: init_scattering => process_beam_config_init_scattering <>= module subroutine process_beam_config_init_scattering & (beam_config, flv_in, sqrts, beam_structure) class(process_beam_config_t), intent(out) :: beam_config type(flavor_t), dimension(2), intent(in) :: flv_in real(default), intent(in) :: sqrts type(beam_structure_t), intent(in), optional :: beam_structure end subroutine process_beam_config_init_scattering <>= module subroutine process_beam_config_init_scattering & (beam_config, flv_in, sqrts, beam_structure) class(process_beam_config_t), intent(out) :: beam_config type(flavor_t), dimension(2), intent(in) :: flv_in real(default), intent(in) :: sqrts type(beam_structure_t), intent(in), optional :: beam_structure if (present (beam_structure)) then if (beam_structure%polarized ()) then call beam_config%data%init_sqrts (sqrts, flv_in, & beam_structure%get_smatrix (), beam_structure%get_pol_f ()) else call beam_config%data%init_sqrts (sqrts, flv_in) end if else call beam_config%data%init_sqrts (sqrts, flv_in) end if end subroutine process_beam_config_init_scattering @ %def process_beam_config_init_scattering @ Initialize the beam setup for a decay process with specified flavor, other properties taken from the beam structure object (if present). For a cascade decay, we set [[rest_frame]] to false, indicating a event-wise varying momentum. The beam data itself are initialized for the particle at rest. <>= procedure :: init_decay => process_beam_config_init_decay <>= module subroutine process_beam_config_init_decay & (beam_config, flv_in, rest_frame, beam_structure) class(process_beam_config_t), intent(out) :: beam_config type(flavor_t), dimension(1), intent(in) :: flv_in logical, intent(in), optional :: rest_frame type(beam_structure_t), intent(in), optional :: beam_structure end subroutine process_beam_config_init_decay <>= module subroutine process_beam_config_init_decay & (beam_config, flv_in, rest_frame, beam_structure) class(process_beam_config_t), intent(out) :: beam_config type(flavor_t), dimension(1), intent(in) :: flv_in logical, intent(in), optional :: rest_frame type(beam_structure_t), intent(in), optional :: beam_structure if (present (beam_structure)) then if (beam_structure%polarized ()) then call beam_config%data%init_decay (flv_in, & beam_structure%get_smatrix (), beam_structure%get_pol_f (), & rest_frame = rest_frame) else call beam_config%data%init_decay (flv_in, rest_frame = rest_frame) end if else call beam_config%data%init_decay (flv_in, & rest_frame = rest_frame) end if beam_config%lab_is_cm = beam_config%data%lab_is_cm end subroutine process_beam_config_init_decay @ %def process_beam_config_init_decay @ Print an informative message. <>= procedure :: startup_message => process_beam_config_startup_message <>= module subroutine process_beam_config_startup_message & (beam_config, unit, beam_structure) class(process_beam_config_t), intent(in) :: beam_config integer, intent(in), optional :: unit type(beam_structure_t), intent(in), optional :: beam_structure end subroutine process_beam_config_startup_message <>= module subroutine process_beam_config_startup_message & (beam_config, unit, beam_structure) class(process_beam_config_t), intent(in) :: beam_config integer, intent(in), optional :: unit type(beam_structure_t), intent(in), optional :: beam_structure integer :: u u = free_unit () open (u, status="scratch", action="readwrite") if (present (beam_structure)) then call beam_structure%write (u) end if call beam_config%data%write (u) rewind (u) do read (u, "(1x,A)", end=1) msg_buffer call msg_message () end do 1 continue close (u) end subroutine process_beam_config_startup_message @ %def process_beam_config_startup_message @ Allocate the structure-function array. <>= procedure :: init_sf_chain => process_beam_config_init_sf_chain <>= module subroutine process_beam_config_init_sf_chain & (beam_config, sf_config, sf_trace_file) class(process_beam_config_t), intent(inout) :: beam_config type(sf_config_t), dimension(:), intent(in) :: sf_config type(string_t), intent(in), optional :: sf_trace_file end subroutine process_beam_config_init_sf_chain <>= module subroutine process_beam_config_init_sf_chain & (beam_config, sf_config, sf_trace_file) class(process_beam_config_t), intent(inout) :: beam_config type(sf_config_t), dimension(:), intent(in) :: sf_config type(string_t), intent(in), optional :: sf_trace_file integer :: i beam_config%n_strfun = size (sf_config) allocate (beam_config%sf (beam_config%n_strfun)) do i = 1, beam_config%n_strfun associate (sf => sf_config(i)) call beam_config%sf(i)%init (sf%i, sf%data) if (.not. sf%data%is_generator ()) then beam_config%n_sfpar = beam_config%n_sfpar + sf%data%get_n_par () end if end associate end do if (present (sf_trace_file)) then beam_config%sf_trace = .true. beam_config%sf_trace_file = sf_trace_file end if end subroutine process_beam_config_init_sf_chain @ %def process_beam_config_init_sf_chain @ Allocate the structure-function mapping channel array, given the requested number of channels. <>= procedure :: allocate_sf_channels => process_beam_config_allocate_sf_channels <>= module subroutine process_beam_config_allocate_sf_channels & (beam_config, n_channel) class(process_beam_config_t), intent(inout) :: beam_config integer, intent(in) :: n_channel end subroutine process_beam_config_allocate_sf_channels <>= module subroutine process_beam_config_allocate_sf_channels & (beam_config, n_channel) class(process_beam_config_t), intent(inout) :: beam_config integer, intent(in) :: n_channel beam_config%n_channel = n_channel call allocate_sf_channels (beam_config%sf_channel, & n_channel = n_channel, & n_strfun = beam_config%n_strfun) end subroutine process_beam_config_allocate_sf_channels @ %def process_beam_config_allocate_sf_channels @ Set a structure-function mapping channel for an array of structure-function entries, for a single channel. (The default is no mapping.) <>= procedure :: set_sf_channel => process_beam_config_set_sf_channel <>= module subroutine process_beam_config_set_sf_channel & (beam_config, c, sf_channel) class(process_beam_config_t), intent(inout) :: beam_config integer, intent(in) :: c type(sf_channel_t), intent(in) :: sf_channel end subroutine process_beam_config_set_sf_channel <>= module subroutine process_beam_config_set_sf_channel & (beam_config, c, sf_channel) class(process_beam_config_t), intent(inout) :: beam_config integer, intent(in) :: c type(sf_channel_t), intent(in) :: sf_channel beam_config%sf_channel(c) = sf_channel end subroutine process_beam_config_set_sf_channel @ %def process_beam_config_set_sf_channel @ Print an informative startup message. <>= procedure :: sf_startup_message => process_beam_config_sf_startup_message <>= module subroutine process_beam_config_sf_startup_message & (beam_config, sf_string, unit) class(process_beam_config_t), intent(in) :: beam_config type(string_t), intent(in) :: sf_string integer, intent(in), optional :: unit end subroutine process_beam_config_sf_startup_message <>= module subroutine process_beam_config_sf_startup_message & (beam_config, sf_string, unit) class(process_beam_config_t), intent(in) :: beam_config type(string_t), intent(in) :: sf_string integer, intent(in), optional :: unit if (beam_config%n_strfun > 0) then call msg_message ("Beam structure: " // char (sf_string), unit = unit) write (msg_buffer, "(A,3(1x,I0,1x,A))") & "Beam structure:", & beam_config%n_channel, "channels,", & beam_config%n_sfpar, "dimensions" call msg_message (unit = unit) if (beam_config%sf_trace) then call msg_message ("Beam structure: tracing & &values in '" // char (beam_config%sf_trace_file) // "'") end if end if end subroutine process_beam_config_sf_startup_message @ %def process_beam_config_startup_message @ Return the PDF set currently in use, if any. This should be unique, so we scan the structure functions until we get a nonzero number. (This implies that if the PDF set is not unique (e.g., proton and photon structure used together), this does not work correctly.) <>= procedure :: get_pdf_set => process_beam_config_get_pdf_set <>= module function process_beam_config_get_pdf_set & (beam_config) result (pdf_set) class(process_beam_config_t), intent(in) :: beam_config integer :: pdf_set end function process_beam_config_get_pdf_set <>= module function process_beam_config_get_pdf_set (beam_config) result (pdf_set) class(process_beam_config_t), intent(in) :: beam_config integer :: pdf_set integer :: i pdf_set = 0 if (allocated (beam_config%sf)) then do i = 1, size (beam_config%sf) pdf_set = beam_config%sf(i)%get_pdf_set () if (pdf_set /= 0) return end do end if end function process_beam_config_get_pdf_set @ %def process_beam_config_get_pdf_set @ Return the beam file. <>= procedure :: get_beam_file => process_beam_config_get_beam_file <>= module function process_beam_config_get_beam_file & (beam_config) result (file) class(process_beam_config_t), intent(in) :: beam_config type(string_t) :: file end function process_beam_config_get_beam_file <>= module function process_beam_config_get_beam_file (beam_config) result (file) class(process_beam_config_t), intent(in) :: beam_config type(string_t) :: file integer :: i file = "" if (allocated (beam_config%sf)) then do i = 1, size (beam_config%sf) file = beam_config%sf(i)%get_beam_file () if (file /= "") return end do end if end function process_beam_config_get_beam_file @ %def process_beam_config_get_beam_file @ Compute the MD5 sum for the complete beam setup. We rely on the default output of [[write]] to contain all relevant data. This is done only once, when the MD5 sum is still empty. <>= procedure :: compute_md5sum => process_beam_config_compute_md5sum <>= module subroutine process_beam_config_compute_md5sum (beam_config) class(process_beam_config_t), intent(inout) :: beam_config end subroutine process_beam_config_compute_md5sum <>= module subroutine process_beam_config_compute_md5sum (beam_config) class(process_beam_config_t), intent(inout) :: beam_config integer :: u if (beam_config%md5sum == "") then u = free_unit () open (u, status = "scratch", action = "readwrite") call beam_config%write (u, verbose=.true.) rewind (u) beam_config%md5sum = md5sum (u) close (u) end if end subroutine process_beam_config_compute_md5sum @ %def process_beam_config_compute_md5sum @ <>= procedure :: get_md5sum => process_beam_config_get_md5sum <>= pure module function process_beam_config_get_md5sum & (beam_config) result (md5) character(32) :: md5 class(process_beam_config_t), intent(in) :: beam_config end function process_beam_config_get_md5sum <>= pure module function process_beam_config_get_md5sum (beam_config) result (md5) character(32) :: md5 class(process_beam_config_t), intent(in) :: beam_config md5 = beam_config%md5sum end function process_beam_config_get_md5sum @ %def process_beam_config_get_md5sum @ <>= procedure :: has_structure_function => & process_beam_config_has_structure_function <>= pure module function process_beam_config_has_structure_function & (beam_config) result (has_sf) logical :: has_sf class(process_beam_config_t), intent(in) :: beam_config end function process_beam_config_has_structure_function <>= pure module function process_beam_config_has_structure_function & (beam_config) result (has_sf) logical :: has_sf class(process_beam_config_t), intent(in) :: beam_config has_sf = beam_config%n_strfun > 0 end function process_beam_config_has_structure_function @ %def process_beam_config_has_structure_function @ \subsection{Process components} A process component is an individual contribution to a process (scattering or decay) which needs not be physical. The sum over all components should be physical. The [[index]] indentifies this component within its parent process. The actual process component is stored in the [[core]] subobject. We use a polymorphic subobject instead of an extension of [[process_component_t]], because the individual entries in the array of process components can have different types. In short, [[process_component_t]] is a wrapper for the actual process variants. If the [[active]] flag is false, we should skip this component. This happens if the associated process has vanishing matrix element. The index array [[i_term]] points to the individual terms generated by this component. The indices refer to the parent process. The index [[i_mci]] is the index of the MC integrator and parameter set which are associated to this process component. <>= public :: process_component_t <>= type :: process_component_t type(process_component_def_t), pointer :: config => null () integer :: index = 0 logical :: active = .false. integer, dimension(:), allocatable :: i_term integer :: i_mci = 0 class(phs_config_t), allocatable :: phs_config character(32) :: md5sum_phs = "" integer :: component_type = COMP_DEFAULT contains <> end type process_component_t @ %def process_component_t @ Finalizer. The MCI template may (potentially) need a finalizer. The process configuration finalizer may include closing an open scratch file. <>= procedure :: final => process_component_final <>= module subroutine process_component_final (object) class(process_component_t), intent(inout) :: object end subroutine process_component_final <>= module subroutine process_component_final (object) class(process_component_t), intent(inout) :: object if (allocated (object%phs_config)) then call object%phs_config%final () end if end subroutine process_component_final @ %def process_component_final @ The meaning of [[verbose]] depends on the process variant. <>= procedure :: write => process_component_write <>= module subroutine process_component_write (object, unit) class(process_component_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine process_component_write <>= module subroutine process_component_write (object, unit) class(process_component_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (associated (object%config)) then write (u, "(1x,A,I0)") "Component #", object%index call object%config%write (u) if (object%md5sum_phs /= "") then write (u, "(3x,A,A,A)") "MD5 sum (phs) = '", & object%md5sum_phs, "'" end if else write (u, "(1x,A)") "Process component: [not allocated]" end if if (.not. object%active) then write (u, "(1x,A)") "[Inactive]" return end if write (u, "(1x,A)") "Referenced data:" if (allocated (object%i_term)) then write (u, "(3x,A,999(1x,I0))") "Terms =", & object%i_term else write (u, "(3x,A)") "Terms = [undefined]" end if if (object%i_mci /= 0) then write (u, "(3x,A,I0)") "MC dataset = ", object%i_mci else write (u, "(3x,A)") "MC dataset = [undefined]" end if if (allocated (object%phs_config)) then call object%phs_config%write (u) end if end subroutine process_component_write @ %def process_component_write @ Initialize the component. <>= procedure :: init => process_component_init <>= module subroutine process_component_init (component, & i_component, env, meta, config, & active, & phs_config_template) class(process_component_t), intent(out) :: component integer, intent(in) :: i_component type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta type(process_config_data_t), intent(in) :: config logical, intent(in) :: active class(phs_config_t), intent(in), allocatable :: phs_config_template end subroutine process_component_init <>= module subroutine process_component_init (component, & i_component, env, meta, config, & active, & phs_config_template) class(process_component_t), intent(out) :: component integer, intent(in) :: i_component type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta type(process_config_data_t), intent(in) :: config logical, intent(in) :: active class(phs_config_t), intent(in), allocatable :: phs_config_template type(process_constants_t) :: data component%index = i_component component%config => & config%process_def%get_component_def_ptr (i_component) component%active = active if (component%active) then allocate (component%phs_config, source = phs_config_template) call env%fill_process_constants (meta%id, i_component, data) call component%phs_config%init (data, config%model) end if end subroutine process_component_init @ %def process_component_init @ <>= procedure :: is_active => process_component_is_active <>= elemental module function process_component_is_active & (component) result (active) logical :: active class(process_component_t), intent(in) :: component end function process_component_is_active <>= elemental module function process_component_is_active & (component) result (active) logical :: active class(process_component_t), intent(in) :: component active = component%active end function process_component_is_active @ %def process_component_is_active @ Finalize the phase-space configuration. <>= procedure :: configure_phs => process_component_configure_phs <>= module subroutine process_component_configure_phs & (component, sqrts, beam_config, rebuild, & ignore_mismatch, subdir) class(process_component_t), intent(inout) :: component real(default), intent(in) :: sqrts type(process_beam_config_t), intent(in) :: beam_config logical, intent(in), optional :: rebuild logical, intent(in), optional :: ignore_mismatch type(string_t), intent(in), optional :: subdir end subroutine process_component_configure_phs <>= module subroutine process_component_configure_phs & (component, sqrts, beam_config, rebuild, & ignore_mismatch, subdir) class(process_component_t), intent(inout) :: component real(default), intent(in) :: sqrts type(process_beam_config_t), intent(in) :: beam_config logical, intent(in), optional :: rebuild logical, intent(in), optional :: ignore_mismatch type(string_t), intent(in), optional :: subdir logical :: no_strfun integer :: nlo_type no_strfun = beam_config%n_strfun == 0 nlo_type = component%config%get_nlo_type () call component%phs_config%configure (sqrts, & azimuthal_dependence = beam_config%azimuthal_dependence, & sqrts_fixed = no_strfun, & lab_is_cm = beam_config%lab_is_cm .and. no_strfun, & rebuild = rebuild, ignore_mismatch = ignore_mismatch, & nlo_type = nlo_type, & subdir = subdir) end subroutine process_component_configure_phs @ %def process_component_configure_phs @ The process component possesses two MD5 sums: the checksum of the component definition, which should be available when the component is initialized, and the phase-space MD5 sum, which is available after configuration. <>= procedure :: compute_md5sum => process_component_compute_md5sum <>= module subroutine process_component_compute_md5sum (component) class(process_component_t), intent(inout) :: component end subroutine process_component_compute_md5sum <>= module subroutine process_component_compute_md5sum (component) class(process_component_t), intent(inout) :: component component%md5sum_phs = component%phs_config%get_md5sum () end subroutine process_component_compute_md5sum @ %def process_component_compute_md5sum @ Match phase-space channels with structure-function channels, where applicable. This calls a method of the [[phs_config]] phase-space implementation. <>= procedure :: collect_channels => process_component_collect_channels <>= module subroutine process_component_collect_channels (component, coll) class(process_component_t), intent(inout) :: component type(phs_channel_collection_t), intent(inout) :: coll end subroutine process_component_collect_channels <>= module subroutine process_component_collect_channels (component, coll) class(process_component_t), intent(inout) :: component type(phs_channel_collection_t), intent(inout) :: coll call component%phs_config%collect_channels (coll) end subroutine process_component_collect_channels @ %def process_component_collect_channels @ <>= procedure :: get_config => process_component_get_config <>= module function process_component_get_config (component) & result (config) type(process_component_def_t) :: config class(process_component_t), intent(in) :: component end function process_component_get_config <>= module function process_component_get_config (component) & result (config) type(process_component_def_t) :: config class(process_component_t), intent(in) :: component config = component%config end function process_component_get_config @ %def process_component_get_config @ <>= procedure :: get_md5sum => process_component_get_md5sum <>= pure module function process_component_get_md5sum (component) result (md5) type(string_t) :: md5 class(process_component_t), intent(in) :: component end function process_component_get_md5sum <>= pure module function process_component_get_md5sum (component) result (md5) type(string_t) :: md5 class(process_component_t), intent(in) :: component md5 = component%config%get_md5sum () // component%md5sum_phs end function process_component_get_md5sum @ %def process_component_get_md5sum @ Return the number of phase-space parameters. <>= procedure :: get_n_phs_par => process_component_get_n_phs_par <>= module function process_component_get_n_phs_par (component) result (n_par) class(process_component_t), intent(in) :: component integer :: n_par end function process_component_get_n_phs_par <>= module function process_component_get_n_phs_par (component) result (n_par) class(process_component_t), intent(in) :: component integer :: n_par n_par = component%phs_config%get_n_par () end function process_component_get_n_phs_par @ %def process_component_get_n_phs_par @ <>= procedure :: get_phs_config => process_component_get_phs_config <>= module subroutine process_component_get_phs_config (component, phs_config) class(process_component_t), intent(in), target :: component class(phs_config_t), intent(out), pointer :: phs_config end subroutine process_component_get_phs_config <>= module subroutine process_component_get_phs_config (component, phs_config) class(process_component_t), intent(in), target :: component class(phs_config_t), intent(out), pointer :: phs_config phs_config => component%phs_config end subroutine process_component_get_phs_config @ %def process_component_get_phs_config @ <>= procedure :: get_nlo_type => process_component_get_nlo_type <>= elemental module function process_component_get_nlo_type & (component) result (nlo_type) integer :: nlo_type class(process_component_t), intent(in) :: component end function process_component_get_nlo_type <>= elemental module function process_component_get_nlo_type & (component) result (nlo_type) integer :: nlo_type class(process_component_t), intent(in) :: component nlo_type = component%config%get_nlo_type () end function process_component_get_nlo_type @ %def process_component_get_nlo_type @ <>= procedure :: needs_mci_entry => process_component_needs_mci_entry <>= module function process_component_needs_mci_entry & (component, combined_integration) result (value) logical :: value class(process_component_t), intent(in) :: component logical, intent(in), optional :: combined_integration end function process_component_needs_mci_entry <>= module function process_component_needs_mci_entry & (component, combined_integration) result (value) logical :: value class(process_component_t), intent(in) :: component logical, intent(in), optional :: combined_integration value = component%active if (present (combined_integration)) then if (combined_integration) & value = value .and. component%component_type <= COMP_MASTER end if end function process_component_needs_mci_entry @ %def process_component_needs_mci_entry @ <>= procedure :: can_be_integrated => process_component_can_be_integrated <>= elemental module function process_component_can_be_integrated & (component) result (active) logical :: active class(process_component_t), intent(in) :: component end function process_component_can_be_integrated <>= elemental module function process_component_can_be_integrated & (component) result (active) logical :: active class(process_component_t), intent(in) :: component active = component%config%can_be_integrated () end function process_component_can_be_integrated @ %def process_component_can_be_integrated @ \subsection{Process terms} For straightforward tree-level calculations, each process component corresponds to a unique elementary interaction. However, in the case of NLO calculations with subtraction terms, a process component may split into several separate contributions to the scattering, which are qualified by interactions with distinct kinematics and particle content. We represent their configuration as [[process_term_t]] objects, the actual instances will be introduced below as [[term_instance_t]]. In any case, the process term contains an elementary interaction with a definite quantum-number and momentum content. The index [[i_term_global]] identifies the term relative to the process. The index [[i_component]] identifies the process component which generates this term, relative to the parent process. The index [[i_term]] identifies the term relative to the process component (not the process). The [[data]] subobject holds all process constants. The number of allowed flavor/helicity/color combinations is stored as [[n_allowed]]. This is the total number of independent entries in the density matrix. For each combination, the index of the flavor, helicity, and color state is stored in the arrays [[flv]], [[hel]], and [[col]], respectively. The flag [[rearrange]] is true if we need to rearrange the particles of the hard interaction, to obtain the effective parton state. The interaction [[int]] holds the quantum state for the (resolved) hard interaction, the parent-child relations of the particles, and their momenta. The momenta are not filled yet; this is postponed to copies of [[int]] which go into the process instances. If recombination is in effect, we should allocate [[int_eff]] to describe the rearranged partonic state. This type is public only for use in a unit test. <>= public :: process_term_t <>= type :: process_term_t integer :: i_term_global = 0 integer :: i_component = 0 integer :: i_term = 0 integer :: i_sub = 0 integer :: i_core = 0 integer :: n_allowed = 0 type(process_constants_t) :: data real(default) :: alpha_s = 0 integer, dimension(:), allocatable :: flv, hel, col integer :: n_sub, n_sub_color, n_sub_spin type(interaction_t) :: int type(interaction_t), pointer :: int_eff => null () contains <> end type process_term_t @ %def process_term_t @ For the output, we skip the process constants and the tables of allowed quantum numbers. Those can also be read off from the interaction object. <>= procedure :: write => process_term_write <>= module subroutine process_term_write (term, unit) class(process_term_t), intent(in) :: term integer, intent(in), optional :: unit end subroutine process_term_write <>= module subroutine process_term_write (term, unit) class(process_term_t), intent(in) :: term integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A,I0)") "Term #", term%i_term_global write (u, "(3x,A,I0)") "Process component index = ", & term%i_component write (u, "(3x,A,I0)") "Term index w.r.t. component = ", & term%i_term call write_separator (u) write (u, "(1x,A)") "Hard interaction:" call write_separator (u) call term%int%basic_write (u) end subroutine process_term_write @ %def process_term_write @ Write an account of all quantum number states and their current status. <>= procedure :: write_state_summary => process_term_write_state_summary <>= module subroutine process_term_write_state_summary (term, core, unit) class(process_term_t), intent(in) :: term class(prc_core_t), intent(in) :: core integer, intent(in), optional :: unit end subroutine process_term_write_state_summary <>= module subroutine process_term_write_state_summary (term, core, unit) class(process_term_t), intent(in) :: term class(prc_core_t), intent(in) :: core integer, intent(in), optional :: unit integer :: u, i, f, h, c type(state_iterator_t) :: it character :: sgn u = given_output_unit (unit) write (u, "(1x,A,I0)") "Term #", term%i_term_global call it%init (term%int%get_state_matrix_ptr ()) do while (it%is_valid ()) i = it%get_me_index () f = term%flv(i) h = term%hel(i) if (allocated (term%col)) then c = term%col(i) else c = 1 end if if (core%is_allowed (term%i_term, f, h, c)) then sgn = "+" else sgn = " " end if write (u, "(1x,A1,1x,I0,2x)", advance="no") sgn, i call quantum_numbers_write (it%get_quantum_numbers (), u) write (u, *) call it%advance () end do end subroutine process_term_write_state_summary @ %def process_term_write_state_summary @ Finalizer: the [[int]] and potentially [[int_eff]] components have a finalizer that we must call. <>= procedure :: final => process_term_final <>= module subroutine process_term_final (term) class(process_term_t), intent(inout) :: term end subroutine process_term_final <>= module subroutine process_term_final (term) class(process_term_t), intent(inout) :: term call term%int%final () end subroutine process_term_final @ %def process_term_final @ Initialize the term. We copy the process constants from the [[core]] object and set up the [[int]] hard interaction accordingly. The [[alpha_s]] value is useful for writing external event records. This is the constant value which may be overridden by an event-specific running value. If the model does not contain the strong coupling, the value is zero. The [[rearrange]] part is commented out; this or something equivalent could become relevant for NLO algorithms. <>= procedure :: init => process_term_init <>= module subroutine process_term_init & (term, i_term_global, i_component, i_term, core, model, & nlo_type, use_beam_pol, subtraction_method, & has_pdfs, n_emitters) class(process_term_t), intent(inout), target :: term integer, intent(in) :: i_term_global integer, intent(in) :: i_component integer, intent(in) :: i_term class(prc_core_t), intent(inout) :: core class(model_data_t), intent(in), target :: model integer, intent(in), optional :: nlo_type logical, intent(in), optional :: use_beam_pol type(string_t), intent(in), optional :: subtraction_method logical, intent(in), optional :: has_pdfs integer, intent(in), optional :: n_emitters end subroutine process_term_init <>= module subroutine process_term_init & (term, i_term_global, i_component, i_term, core, model, & nlo_type, use_beam_pol, subtraction_method, & has_pdfs, n_emitters) class(process_term_t), intent(inout), target :: term integer, intent(in) :: i_term_global integer, intent(in) :: i_component integer, intent(in) :: i_term class(prc_core_t), intent(inout) :: core class(model_data_t), intent(in), target :: model integer, intent(in), optional :: nlo_type logical, intent(in), optional :: use_beam_pol type(string_t), intent(in), optional :: subtraction_method logical, intent(in), optional :: has_pdfs integer, intent(in), optional :: n_emitters class(modelpar_data_t), pointer :: alpha_s_ptr logical :: use_internal_color term%i_term_global = i_term_global term%i_component = i_component term%i_term = i_term call core%get_constants (term%data, i_term) alpha_s_ptr => model%get_par_data_ptr (var_str ("alphas")) if (associated (alpha_s_ptr)) then term%alpha_s = alpha_s_ptr%get_real () else term%alpha_s = -1 end if use_internal_color = .false. if (present (subtraction_method)) & use_internal_color = (char (subtraction_method) == 'omega') & .or. (char (subtraction_method) == 'threshold') call term%setup_interaction (core, model, nlo_type = nlo_type, & pol_beams = use_beam_pol, use_internal_color = use_internal_color, & has_pdfs = has_pdfs, n_emitters = n_emitters) end subroutine process_term_init @ %def process_term_init @ We fetch the process constants which determine the quantum numbers and use those to create the interaction. The interaction contains incoming and outgoing particles, no virtuals. The incoming particles are parents of the outgoing ones. Keeping previous \whizard\ conventions, we invert the color assignment (but not flavor or helicity) for the incoming particles. When the color-flow square matrix is evaluated, this inversion is done again, so in the color-flow sequence we get the color assignments of the matrix element. \textbf{Why are these four subtraction entries for structure-function aware interactions?} Taking the soft or collinear limit of the real-emission matrix element, the behavior of the parton energy fractions has to be taken into account. In the pure real case, $x_\oplus$ and $x_\ominus$ are given by \begin{equation*} x_\oplus = \frac{\bar{x}_\oplus}{\sqrt{1-\xi}} \sqrt{\frac{2 - \xi(1-y)}{2 - \xi(1+y)}}, \quad x_\ominus = \frac{\bar{x}_\ominus}{\sqrt{1-\xi}} \sqrt{\frac{2 - \xi(1+y)}{2 - \xi(1-y)}}. \end{equation*} In the soft limit, $\xi \to 0$, this yields $x_\oplus = \bar{x}_\oplus$ and $x_\ominus = \bar{x}_\ominus$. In the collinear limit, $y \to 1$, it is $x_\oplus = \bar{x}_\oplus / (1 - \xi)$ and $x_\ominus = \bar{x}_\ominus$. Likewise, in the anti-collinear limit $y \to -1$, the inverse relation holds. We therefore have to distinguish four cases with the PDF assignments $f(x_\oplus) \cdot f(x_\ominus)$, $f(\bar{x}_\oplus) \cdot f(\bar{x}_\ominus)$, $f\left(\bar{x}_\oplus / (1-\xi)\right) \cdot f(\bar{x}_\ominus)$ and $f(\bar{x}_\oplus) \cdot f\left(\bar{x}_\ominus / (1-\xi)\right)$. The [[n_emitters]] optional argument is provided by the caller if this term requires spin-correlated matrix elements, and thus involves additional subtractions. <>= procedure :: setup_interaction => process_term_setup_interaction <>= module subroutine process_term_setup_interaction (term, core, model, & nlo_type, pol_beams, has_pdfs, use_internal_color, n_emitters) class(process_term_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core class(model_data_t), intent(in), target :: model logical, intent(in), optional :: pol_beams logical, intent(in), optional :: has_pdfs integer, intent(in), optional :: nlo_type logical, intent(in), optional :: use_internal_color integer, intent(in), optional :: n_emitters end subroutine process_term_setup_interaction <>= module subroutine process_term_setup_interaction (term, core, model, & nlo_type, pol_beams, has_pdfs, use_internal_color, n_emitters) class(process_term_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core class(model_data_t), intent(in), target :: model logical, intent(in), optional :: pol_beams logical, intent(in), optional :: has_pdfs integer, intent(in), optional :: nlo_type logical, intent(in), optional :: use_internal_color integer, intent(in), optional :: n_emitters integer :: n, n_tot type(flavor_t), dimension(:), allocatable :: flv type(color_t), dimension(:), allocatable :: col type(helicity_t), dimension(:), allocatable :: hel type(quantum_numbers_t), dimension(:), allocatable :: qn logical :: is_pol, use_color integer :: nlo_t, n_sub is_pol = .false.; if (present (pol_beams)) is_pol = pol_beams nlo_t = BORN; if (present (nlo_type)) nlo_t = nlo_type n_tot = term%data%n_in + term%data%n_out call count_number_of_states () term%n_allowed = n call compute_n_sub (n_emitters, has_pdfs) call fill_quantum_numbers () call term%int%basic_init & (term%data%n_in, 0, term%data%n_out, set_relations = .true.) select type (core) class is (prc_blha_t) call setup_states_blha_olp () type is (prc_threshold_t) call setup_states_threshold () class is (prc_external_t) call setup_states_other_prc_external () class default call setup_states_omega () end select call term%int%freeze () contains subroutine count_number_of_states () integer :: f, h, c n = 0 select type (core) class is (prc_external_t) do f = 1, term%data%n_flv do h = 1, term%data%n_hel do c = 1, term%data%n_col n = n + 1 end do end do end do class default !!! Omega and all test cores do f = 1, term%data%n_flv do h = 1, term%data%n_hel do c = 1, term%data%n_col if (core%is_allowed (term%i_term, f, h, c)) n = n + 1 end do end do end do end select end subroutine count_number_of_states subroutine compute_n_sub (n_emitters, has_pdfs) integer, intent(in), optional :: n_emitters logical, intent(in), optional :: has_pdfs logical :: can_have_sub integer :: n_sub_color, n_sub_spin use_color = .false.; if (present (use_internal_color)) & use_color = use_internal_color can_have_sub = nlo_t == NLO_VIRTUAL .or. & (nlo_t == NLO_REAL .and. term%i_term_global == term%i_sub) .or. & nlo_t == NLO_MISMATCH .or. nlo_t == NLO_DGLAP n_sub_color = 0; n_sub_spin = 0 if (can_have_sub) then if (.not. use_color) n_sub_color = n_tot * (n_tot - 1) / 2 if (nlo_t == NLO_REAL) then if (present (n_emitters)) then n_sub_spin = 6 * n_emitters end if end if end if n_sub = n_sub_color + n_sub_spin !!! For the virtual subtraction we also need the finite virtual contribution !!! corresponding to the $\epsilon^0$-pole if (nlo_t == NLO_VIRTUAL) n_sub = n_sub + 1 if (present (has_pdfs)) then if (has_pdfs & .and. ((nlo_t == NLO_REAL .and. can_have_sub) & .or. nlo_t == NLO_DGLAP)) then !!! necessary dummy, needs refactoring, !!! c.f. [[term_instance_evaluate_interaction_external_tree]] n_sub = n_sub + n_beams_rescaled end if end if term%n_sub = n_sub term%n_sub_color = n_sub_color term%n_sub_spin = n_sub_spin end subroutine compute_n_sub subroutine fill_quantum_numbers () integer :: nn logical :: can_have_sub select type (core) class is (prc_external_t) can_have_sub = nlo_t == NLO_VIRTUAL .or. & (nlo_t == NLO_REAL .and. term%i_term_global == term%i_sub) .or. & nlo_t == NLO_MISMATCH .or. nlo_t == NLO_DGLAP if (can_have_sub) then nn = (n_sub + 1) * n else nn = n end if class default nn = n end select allocate (term%flv (nn), term%col (nn), term%hel (nn)) allocate (flv (n_tot), col (n_tot), hel (n_tot)) allocate (qn (n_tot)) end subroutine fill_quantum_numbers subroutine setup_states_blha_olp () integer :: s, f, c, h, i i = 0 associate (data => term%data) do s = 0, n_sub do f = 1, data%n_flv do h = 1, data%n_hel do c = 1, data%n_col i = i + 1 term%flv(i) = f term%hel(i) = h !!! Dummy-initialization of color term%col(i) = c call flv%init (data%flv_state (:,f), model) call color_init_from_array (col, & data%col_state(:,:,c), data%ghost_flag(:,c)) call col(1:data%n_in)%invert () if (is_pol) then select type (core) type is (prc_openloops_t) call hel%init (data%hel_state (:,h)) call qn%init (flv, hel, col, s) class default call msg_fatal ("Polarized beams only supported by OpenLoops") end select else call qn%init (flv, col, s) end if call qn%tag_hard_process () call term%int%add_state (qn) end do end do end do end do end associate end subroutine setup_states_blha_olp subroutine setup_states_threshold () integer :: s, f, c, h, i i = 0 n_sub = 0; if (nlo_t == NLO_VIRTUAL) n_sub = 1 associate (data => term%data) do s = 0, n_sub do f = 1, term%data%n_flv do h = 1, data%n_hel do c = 1, data%n_col i = i + 1 term%flv(i) = f term%hel(i) = h !!! Dummy-initialization of color term%col(i) = 1 call flv%init (term%data%flv_state (:,f), model) if (is_pol) then call hel%init (data%hel_state (:,h)) call qn%init (flv, hel, s) else call qn%init (flv, s) end if call qn%tag_hard_process () call term%int%add_state (qn) end do end do end do end do end associate end subroutine setup_states_threshold subroutine setup_states_other_prc_external () integer :: s, f, i, c, h if (is_pol) & call msg_fatal ("Polarized beams only supported by OpenLoops") i = 0 !!! n_sub = 0; if (nlo_t == NLO_VIRTUAL) n_sub = 1 associate (data => term%data) do s = 0, n_sub do f = 1, data%n_flv do h = 1, data%n_hel do c = 1, data%n_col i = i + 1 term%flv(i) = f term%hel(i) = h !!! Dummy-initialization of color term%col(i) = c call flv%init (data%flv_state (:,f), model) call color_init_from_array (col, & data%col_state(:,:,c), data%ghost_flag(:,c)) call col(1:data%n_in)%invert () call qn%init (flv, col, s) call qn%tag_hard_process () call term%int%add_state (qn) end do end do end do end do end associate end subroutine setup_states_other_prc_external subroutine setup_states_omega () integer :: f, h, c, i i = 0 associate (data => term%data) do f = 1, data%n_flv do h = 1, data%n_hel do c = 1, data%n_col if (core%is_allowed (term%i_term, f, h, c)) then i = i + 1 term%flv(i) = f term%hel(i) = h term%col(i) = c call flv%init (data%flv_state(:,f), model) call color_init_from_array (col, & data%col_state(:,:,c), & data%ghost_flag(:,c)) call col(:data%n_in)%invert () call hel%init (data%hel_state(:,h)) call qn%init (flv, col, hel) call qn%tag_hard_process () call term%int%add_state (qn) end if end do end do end do end associate end subroutine setup_states_omega end subroutine process_term_setup_interaction @ %def process_term_setup_interaction @ <>= procedure :: get_process_constants => process_term_get_process_constants <>= module subroutine process_term_get_process_constants & (term, prc_constants) class(process_term_t), intent(inout) :: term type(process_constants_t), intent(out) :: prc_constants end subroutine process_term_get_process_constants <>= module subroutine process_term_get_process_constants & (term, prc_constants) class(process_term_t), intent(inout) :: term type(process_constants_t), intent(out) :: prc_constants prc_constants = term%data end subroutine process_term_get_process_constants @ %def process_term_get_process_constants @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process call statistics} Very simple object for statistics. Could be moved to a more basic chapter. <<[[process_counter.f90]]>>= <> module process_counter <> <> <> <> interface <> end interface end module process_counter @ %def process_counter @ This object can record process calls, categorized by evaluation status. It is a part of the [[mci_entry]] component below. <>= public :: process_counter_t <>= type :: process_counter_t integer :: total = 0 integer :: failed_kinematics = 0 integer :: failed_cuts = 0 integer :: has_passed = 0 integer :: evaluated = 0 integer :: complete = 0 contains <> end type process_counter_t @ %def process_counter_t @ Here are the corresponding numeric codes: <>= integer, parameter, public :: STAT_UNDEFINED = 0 integer, parameter, public :: STAT_INITIAL = 1 integer, parameter, public :: STAT_ACTIVATED = 2 integer, parameter, public :: STAT_BEAM_MOMENTA = 3 integer, parameter, public :: STAT_FAILED_KINEMATICS = 4 integer, parameter, public :: STAT_SEED_KINEMATICS = 5 integer, parameter, public :: STAT_HARD_KINEMATICS = 6 integer, parameter, public :: STAT_EFF_KINEMATICS = 7 integer, parameter, public :: STAT_FAILED_CUTS = 8 integer, parameter, public :: STAT_PASSED_CUTS = 9 integer, parameter, public :: STAT_EVALUATED_TRACE = 10 integer, parameter, public :: STAT_EVENT_COMPLETE = 11 @ %def STAT_UNDEFINED STAT_INITIAL STAT_ACTIVATED @ %def STAT_BEAM_MOMENTA STAT_FAILED_KINEMATICS @ %def STAT_SEED_KINEMATICS STAT_HARD_KINEMATICS STAT_EFF_KINEMATICS @ %def STAT_EVALUATED_TRACE STAT_EVENT_COMPLETE @ Output. <>= procedure :: write => process_counter_write <>= module subroutine process_counter_write (object, unit) class(process_counter_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine process_counter_write <>= module subroutine process_counter_write (object, unit) class(process_counter_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (object%total > 0) then write (u, "(1x,A)") "Call statistics (current run):" write (u, "(3x,A,I0)") "total = ", object%total write (u, "(3x,A,I0)") "failed kin. = ", object%failed_kinematics write (u, "(3x,A,I0)") "failed cuts = ", object%failed_cuts write (u, "(3x,A,I0)") "passed cuts = ", object%has_passed write (u, "(3x,A,I0)") "evaluated = ", object%evaluated else write (u, "(1x,A)") "Call statistics (current run): [no calls]" end if end subroutine process_counter_write @ %def process_counter_write @ <<[[process_counter_sub.f90]]>>= <> submodule (process_counter) process_counter_s use io_units implicit none contains <> end submodule process_counter_s @ %def process_counter_s @ Reset. Just enforce default initialization. <>= procedure :: reset => process_counter_reset <>= module subroutine process_counter_reset (counter) class(process_counter_t), intent(out) :: counter end subroutine process_counter_reset <>= module subroutine process_counter_reset (counter) class(process_counter_t), intent(out) :: counter counter%total = 0 counter%failed_kinematics = 0 counter%failed_cuts = 0 counter%has_passed = 0 counter%evaluated = 0 counter%complete = 0 end subroutine process_counter_reset @ %def process_counter_reset @ We record an event according to the lowest status code greater or equal to the actual status. This is actually done by the process instance; the process object just copies the instance counter. <>= procedure :: record => process_counter_record <>= module subroutine process_counter_record (counter, status) class(process_counter_t), intent(inout) :: counter integer, intent(in) :: status end subroutine process_counter_record <>= module subroutine process_counter_record (counter, status) class(process_counter_t), intent(inout) :: counter integer, intent(in) :: status if (status <= STAT_FAILED_KINEMATICS) then counter%failed_kinematics = counter%failed_kinematics + 1 else if (status <= STAT_FAILED_CUTS) then counter%failed_cuts = counter%failed_cuts + 1 else if (status <= STAT_PASSED_CUTS) then counter%has_passed = counter%has_passed + 1 else counter%evaluated = counter%evaluated + 1 end if counter%total = counter%total + 1 end subroutine process_counter_record @ %def process_counter_record @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Multi-channel integration} <<[[process_mci.f90]]>>= <> module process_mci <> <> use cputime use rng_base use mci_base use variables use integration_results use process_libraries use phs_base use process_counter use process_config <> <> <> <> interface <> end interface end module process_mci @ %def process_mci @ <<[[process_mci_sub.f90]]>>= <> submodule (process_mci) process_mci_s <> use io_units use diagnostics use physics_defs use md5 implicit none contains <> end submodule process_mci_s @ %def process_mci_s \subsection{Process MCI entry} The [[process_mci_entry_t]] block contains, for each process component that is integrated independently, the configuration data for its MC input parameters. Each input parameter set is handled by a [[mci_t]] integrator. The MC input parameter set is broken down into the parameters required by the structure-function chain and the parameters required by the phase space of the elementary process. The MD5 sum collects all information about the associated processes that may affect the integration. It does not contain the MCI object itself or integration results. MC integration is organized in passes. Each pass may consist of several iterations, and for each iteration there is a number of calls. We store explicitly the values that apply to the current pass. Previous values are archived in the [[results]] object. The [[counter]] receives the counter statistics from the associated process instance, for diagnostics. The [[results]] object records results, broken down in passes and iterations. <>= public :: process_mci_entry_t <>= type :: process_mci_entry_t integer :: i_mci = 0 integer, dimension(:), allocatable :: i_component integer :: process_type = PRC_UNKNOWN integer :: n_par = 0 integer :: n_par_sf = 0 integer :: n_par_phs = 0 character(32) :: md5sum = "" integer :: pass = 0 integer :: n_it = 0 integer :: n_calls = 0 logical :: activate_timer = .false. real(default) :: error_threshold = 0 class(mci_t), allocatable :: mci type(process_counter_t) :: counter type(integration_results_t) :: results logical :: negative_weights = .false. logical :: combined_integration = .false. integer :: real_partition_type = REAL_FULL contains <> end type process_mci_entry_t @ %def process_mci_entry_t @ Finalizer for the [[mci]] component. <>= procedure :: final => process_mci_entry_final <>= module subroutine process_mci_entry_final (object) class(process_mci_entry_t), intent(inout) :: object end subroutine process_mci_entry_final <>= module subroutine process_mci_entry_final (object) class(process_mci_entry_t), intent(inout) :: object if (allocated (object%mci)) call object%mci%final () end subroutine process_mci_entry_final @ %def process_mci_entry_final @ Output. Write pass/iteration information only if set (the pass index is nonzero). Write the MCI block only if it exists (for some self-tests it does not). Write results only if there are any. <>= procedure :: write => process_mci_entry_write <>= module subroutine process_mci_entry_write (object, unit, pacify) class(process_mci_entry_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify end subroutine process_mci_entry_write <>= module subroutine process_mci_entry_write (object, unit, pacify) class(process_mci_entry_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify integer :: u u = given_output_unit (unit) write (u, "(3x,A,I0)") "Associated components = ", object%i_component write (u, "(3x,A,I0)") "MC input parameters = ", object%n_par write (u, "(3x,A,I0)") "MC parameters (SF) = ", object%n_par_sf write (u, "(3x,A,I0)") "MC parameters (PHS) = ", object%n_par_phs if (object%pass > 0) then write (u, "(3x,A,I0)") "Current pass = ", object%pass write (u, "(3x,A,I0)") "Number of iterations = ", object%n_it write (u, "(3x,A,I0)") "Number of calls = ", object%n_calls end if if (object%md5sum /= "") then write (u, "(3x,A,A,A)") "MD5 sum (components) = '", object%md5sum, "'" end if if (allocated (object%mci)) then call object%mci%write (u) end if call object%counter%write (u) if (object%results%exist ()) then call object%results%write (u, suppress = pacify) call object%results%write_chain_weights (u) end if end subroutine process_mci_entry_write @ %def process_mci_entry_write @ Configure the MCI entry. This is intent(inout) since some specific settings may be done before this. The actual [[mci_t]] object is an instance of the [[mci_template]] argument, which determines the concrete types. In a unit-test context, the [[mci_template]] argument may be unallocated. We obtain the number of channels and the number of parameters separately for the structure-function chain and for the associated process component. We assume that the phase-space object has already been configured. We assume that there is only one process component directly associated with an MCI entry. <>= procedure :: configure => process_mci_entry_configure <>= module subroutine process_mci_entry_configure (mci_entry, mci_template, & process_type, i_mci, i_component, component, & n_sfpar, rng_factory) class(process_mci_entry_t), intent(inout) :: mci_entry class(mci_t), intent(in), allocatable :: mci_template integer, intent(in) :: process_type integer, intent(in) :: i_mci integer, intent(in) :: i_component type(process_component_t), intent(in), target :: component integer, intent(in) :: n_sfpar class(rng_factory_t), intent(inout) :: rng_factory end subroutine process_mci_entry_configure <>= module subroutine process_mci_entry_configure (mci_entry, mci_template, & process_type, i_mci, i_component, component, & n_sfpar, rng_factory) class(process_mci_entry_t), intent(inout) :: mci_entry class(mci_t), intent(in), allocatable :: mci_template integer, intent(in) :: process_type integer, intent(in) :: i_mci integer, intent(in) :: i_component type(process_component_t), intent(in), target :: component integer, intent(in) :: n_sfpar class(rng_factory_t), intent(inout) :: rng_factory class(rng_t), allocatable :: rng associate (phs_config => component%phs_config) mci_entry%i_mci = i_mci call mci_entry%create_component_list (i_component, component%get_config ()) mci_entry%n_par_sf = n_sfpar mci_entry%n_par_phs = phs_config%get_n_par () mci_entry%n_par = mci_entry%n_par_sf + mci_entry%n_par_phs mci_entry%process_type = process_type if (allocated (mci_template)) then allocate (mci_entry%mci, source = mci_template) call mci_entry%mci%record_index (mci_entry%i_mci) call mci_entry%mci%set_dimensions & (mci_entry%n_par, phs_config%get_n_channel ()) call mci_entry%mci%declare_flat_dimensions & (phs_config%get_flat_dimensions ()) if (phs_config%provides_equivalences) then call mci_entry%mci%declare_equivalences & (phs_config%channel, mci_entry%n_par_sf) end if if (phs_config%provides_chains) then call mci_entry%mci%declare_chains (phs_config%chain) end if call rng_factory%make (rng) call mci_entry%mci%import_rng (rng) end if call mci_entry%results%init (process_type) end associate end subroutine process_mci_entry_configure @ %def process_mci_entry_configure @ <>= integer, parameter, public :: REAL_FULL = 0 integer, parameter, public :: REAL_SINGULAR = 1 integer, parameter, public :: REAL_FINITE = 2 @ <>= procedure :: create_component_list => & process_mci_entry_create_component_list <>= module subroutine process_mci_entry_create_component_list (mci_entry, & i_component, component_config) class (process_mci_entry_t), intent(inout) :: mci_entry integer, intent(in) :: i_component type(process_component_def_t), intent(in) :: component_config end subroutine process_mci_entry_create_component_list <>= module subroutine process_mci_entry_create_component_list (mci_entry, & i_component, component_config) class (process_mci_entry_t), intent(inout) :: mci_entry integer, intent(in) :: i_component type(process_component_def_t), intent(in) :: component_config integer, dimension(:), allocatable :: i_list integer :: n integer, save :: i_rfin_offset = 0 if (debug_on) call msg_debug & (D_PROCESS_INTEGRATION, "process_mci_entry_create_component_list") if (mci_entry%combined_integration) then if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, & "mci_entry%real_partition_type", mci_entry%real_partition_type) n = get_n_components (mci_entry%real_partition_type) allocate (i_list (n)) select case (mci_entry%real_partition_type) case (REAL_FULL) i_list = component_config%get_association_list () allocate (mci_entry%i_component (size (i_list))) mci_entry%i_component = i_list case (REAL_SINGULAR) i_list = component_config%get_association_list (ASSOCIATED_REAL_FIN) allocate (mci_entry%i_component (size(i_list))) mci_entry%i_component = i_list case (REAL_FINITE) allocate (mci_entry%i_component (1)) mci_entry%i_component(1) = & component_config%get_associated_real_fin () + i_rfin_offset i_rfin_offset = i_rfin_offset + 1 end select else allocate (mci_entry%i_component (1)) mci_entry%i_component(1) = i_component end if contains function get_n_components (real_partition_type) result (n_components) integer :: n_components integer, intent(in) :: real_partition_type select case (real_partition_type) case (REAL_FULL) n_components = size (component_config%get_association_list ()) case (REAL_SINGULAR) n_components = size (component_config%get_association_list & (ASSOCIATED_REAL_FIN)) end select if (debug_on) call msg_debug & (D_PROCESS_INTEGRATION, "n_components", n_components) end function get_n_components end subroutine process_mci_entry_create_component_list @ %def process_mci_entry_create_component_list @ Set some additional parameters. <>= procedure :: set_parameters => process_mci_entry_set_parameters <>= module subroutine process_mci_entry_set_parameters (mci_entry, var_list) class(process_mci_entry_t), intent(inout) :: mci_entry type(var_list_t), intent(in) :: var_list end subroutine process_mci_entry_set_parameters <>= module subroutine process_mci_entry_set_parameters (mci_entry, var_list) class(process_mci_entry_t), intent(inout) :: mci_entry type(var_list_t), intent(in) :: var_list integer :: integration_results_verbosity real(default) :: error_threshold integration_results_verbosity = & var_list%get_ival (var_str ("integration_results_verbosity")) error_threshold = & var_list%get_rval (var_str ("error_threshold")) mci_entry%activate_timer = & var_list%get_lval (var_str ("?integration_timer")) call mci_entry%results%set_verbosity (integration_results_verbosity) call mci_entry%results%set_error_threshold (error_threshold) end subroutine process_mci_entry_set_parameters @ %def process_mci_entry_set_parameters @ Compute an MD5 sum that summarizes all information that could influence integration results, for the associated process components. We take the process-configuration MD5 sum which represents parameters, cuts, etc., the MD5 sums for the process component definitions and their phase space objects (which should be configured), and the beam configuration MD5 sum. (The QCD setup is included in the process configuration data MD5 sum.) Done only once, when the MD5 sum is still empty. <>= procedure :: compute_md5sum => process_mci_entry_compute_md5sum <>= module subroutine process_mci_entry_compute_md5sum (mci_entry, & config, component, beam_config) class(process_mci_entry_t), intent(inout) :: mci_entry type(process_config_data_t), intent(in) :: config type(process_component_t), dimension(:), intent(in) :: component type(process_beam_config_t), intent(in) :: beam_config end subroutine process_mci_entry_compute_md5sum <>= module subroutine process_mci_entry_compute_md5sum (mci_entry, & config, component, beam_config) class(process_mci_entry_t), intent(inout) :: mci_entry type(process_config_data_t), intent(in) :: config type(process_component_t), dimension(:), intent(in) :: component type(process_beam_config_t), intent(in) :: beam_config type(string_t) :: buffer integer :: i if (mci_entry%md5sum == "") then buffer = config%get_md5sum () // beam_config%get_md5sum () do i = 1, size (component) if (component(i)%is_active ()) then buffer = buffer // component(i)%get_md5sum () end if end do mci_entry%md5sum = md5sum (char (buffer)) end if if (allocated (mci_entry%mci)) then call mci_entry%mci%set_md5sum (mci_entry%md5sum) end if end subroutine process_mci_entry_compute_md5sum @ %def process_mci_entry_compute_md5sum @ Test the MCI sampler by calling it a given number of time, discarding the results. The instance should be initialized. The [[mci_entry]] is [[intent(inout)]] because the integrator contains the random-number state. <>= procedure :: sampler_test => process_mci_entry_sampler_test <>= module subroutine process_mci_entry_sampler_test & (mci_entry, mci_sampler, n_calls) class(process_mci_entry_t), intent(inout) :: mci_entry class(mci_sampler_t), intent(inout), target :: mci_sampler integer, intent(in) :: n_calls end subroutine process_mci_entry_sampler_test <>= module subroutine process_mci_entry_sampler_test & (mci_entry, mci_sampler, n_calls) class(process_mci_entry_t), intent(inout) :: mci_entry class(mci_sampler_t), intent(inout), target :: mci_sampler integer, intent(in) :: n_calls call mci_entry%mci%sampler_test (mci_sampler, n_calls) end subroutine process_mci_entry_sampler_test @ %def process_mci_entry_sampler_test @ Integrate. The [[integrate]] method counts as an integration pass; the pass count is increased by one. We transfer the pass parameters (number of iterations and number of calls) to the actual integration routine. The [[mci_entry]] is [[intent(inout)]] because the integrator contains the random-number state. Note: The results are written to screen and to logfile. This behavior is hardcoded. <>= procedure :: integrate => process_mci_entry_integrate procedure :: final_integration => process_mci_entry_final_integration <>= module subroutine process_mci_entry_integrate (mci_entry, mci_instance, & mci_sampler, n_it, n_calls, & adapt_grids, adapt_weights, final, pacify, & nlo_type) class(process_mci_entry_t), intent(inout) :: mci_entry class(mci_instance_t), intent(inout) :: mci_instance class(mci_sampler_t), intent(inout) :: mci_sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: adapt_grids logical, intent(in), optional :: adapt_weights logical, intent(in), optional :: final, pacify integer, intent(in), optional :: nlo_type end subroutine process_mci_entry_integrate module subroutine process_mci_entry_final_integration (mci_entry) class(process_mci_entry_t), intent(inout) :: mci_entry end subroutine process_mci_entry_final_integration <>= module subroutine process_mci_entry_integrate (mci_entry, mci_instance, & mci_sampler, n_it, n_calls, & adapt_grids, adapt_weights, final, pacify, & nlo_type) class(process_mci_entry_t), intent(inout) :: mci_entry class(mci_instance_t), intent(inout) :: mci_instance class(mci_sampler_t), intent(inout) :: mci_sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: adapt_grids logical, intent(in), optional :: adapt_weights logical, intent(in), optional :: final, pacify integer, intent(in), optional :: nlo_type integer :: u_log u_log = logfile_unit () mci_entry%pass = mci_entry%pass + 1 mci_entry%n_it = n_it mci_entry%n_calls = n_calls if (mci_entry%pass == 1) & call mci_entry%mci%startup_message (n_calls = n_calls) call mci_entry%mci%set_timer (active = mci_entry%activate_timer) call mci_entry%results%display_init (screen = .true., unit = u_log) call mci_entry%results%new_pass () if (present (nlo_type)) then select case (nlo_type) case (NLO_VIRTUAL, NLO_REAL, NLO_MISMATCH, NLO_DGLAP) mci_instance%negative_weights = .true. end select end if call mci_entry%mci%add_pass (adapt_grids, adapt_weights, final) call mci_entry%mci%start_timer () call mci_entry%mci%integrate (mci_instance, mci_sampler, n_it, & n_calls, mci_entry%results, pacify = pacify) call mci_entry%mci%stop_timer () if (signal_is_pending ()) return end subroutine process_mci_entry_integrate module subroutine process_mci_entry_final_integration (mci_entry) class(process_mci_entry_t), intent(inout) :: mci_entry call mci_entry%results%display_final () call mci_entry%time_message () end subroutine process_mci_entry_final_integration @ %def process_mci_entry_integrate @ %def process_mci_entry_final_integration @ If appropriate, issue an informative message about the expected time for an event sample. <>= procedure :: get_time => process_mci_entry_get_time procedure :: time_message => process_mci_entry_time_message <>= module subroutine process_mci_entry_get_time (mci_entry, time, sample) class(process_mci_entry_t), intent(in) :: mci_entry type(time_t), intent(out) :: time integer, intent(in) :: sample end subroutine process_mci_entry_get_time module subroutine process_mci_entry_time_message (mci_entry) class(process_mci_entry_t), intent(in) :: mci_entry end subroutine process_mci_entry_time_message <>= module subroutine process_mci_entry_get_time (mci_entry, time, sample) class(process_mci_entry_t), intent(in) :: mci_entry type(time_t), intent(out) :: time integer, intent(in) :: sample real(default) :: time_last_pass, efficiency, calls time_last_pass = mci_entry%mci%get_time () calls = mci_entry%results%get_n_calls () efficiency = mci_entry%mci%get_efficiency () if (time_last_pass > 0 .and. calls > 0 .and. efficiency > 0) then time = nint (time_last_pass / calls / efficiency * sample) end if end subroutine process_mci_entry_get_time module subroutine process_mci_entry_time_message (mci_entry) class(process_mci_entry_t), intent(in) :: mci_entry type(time_t) :: time integer :: sample sample = 10000 call mci_entry%get_time (time, sample) if (time%is_known ()) then call msg_message ("Time estimate for generating 10000 events: " & // char (time%to_string_dhms ())) end if end subroutine process_mci_entry_time_message @ %def process_mci_entry_time_message @ Prepare event generation. (For the test integrator, this does nothing. It is relevant for the VAMP integrator.) <>= procedure :: prepare_simulation => process_mci_entry_prepare_simulation <>= module subroutine process_mci_entry_prepare_simulation (mci_entry) class(process_mci_entry_t), intent(inout) :: mci_entry end subroutine process_mci_entry_prepare_simulation <>= module subroutine process_mci_entry_prepare_simulation (mci_entry) class(process_mci_entry_t), intent(inout) :: mci_entry call mci_entry%mci%prepare_simulation () end subroutine process_mci_entry_prepare_simulation @ %def process_mci_entry_prepare_simulation @ Generate an event. The instance should be initialized, otherwise event generation is directed by the [[mci]] integrator subobject. The integrator instance is contained in a [[mci_work]] subobject of the process instance, which simultaneously serves as the sampler object. (We avoid the anti-aliasing rules if we assume that the sampling itself does not involve the integrator instance contained in the process instance.) Regarding weighted events, we only take events which are valid, which means that they have valid kinematics and have passed cuts. Therefore, we have a rejection loop. For unweighted events, the unweighting routine should already take care of this. The [[keep_failed]] flag determines whether events which failed cuts are nevertheless produced, to be recorded with zero weight. Alternatively, failed events are dropped, and this fact is recorded by the counter [[n_dropped]]. <>= procedure :: generate_weighted_event => & process_mci_entry_generate_weighted_event procedure :: generate_unweighted_event => & process_mci_entry_generate_unweighted_event <>= module subroutine process_mci_entry_generate_weighted_event (mci_entry, & mci_instance, mci_sampler, keep_failed) class(process_mci_entry_t), intent(inout) :: mci_entry class(mci_instance_t), intent(inout) :: mci_instance class(mci_sampler_t), intent(inout) :: mci_sampler logical, intent(in) :: keep_failed end subroutine process_mci_entry_generate_weighted_event module subroutine process_mci_entry_generate_unweighted_event & (mci_entry, mci_instance, mci_sampler) class(process_mci_entry_t), intent(inout) :: mci_entry class(mci_instance_t), intent(inout) :: mci_instance class(mci_sampler_t), intent(inout) :: mci_sampler end subroutine process_mci_entry_generate_unweighted_event <>= module subroutine process_mci_entry_generate_weighted_event (mci_entry, & mci_instance, mci_sampler, keep_failed) class(process_mci_entry_t), intent(inout) :: mci_entry class(mci_instance_t), intent(inout) :: mci_instance class(mci_sampler_t), intent(inout) :: mci_sampler logical, intent(in) :: keep_failed logical :: generate_new generate_new = .true. call mci_instance%reset_n_event_dropped () REJECTION: do while (generate_new) call mci_entry%mci%generate_weighted_event (mci_instance, mci_sampler) if (signal_is_pending ()) return if (.not. mci_sampler%is_valid()) then if (keep_failed) then generate_new = .false. else call mci_instance%record_event_dropped () generate_new = .true. end if else generate_new = .false. end if end do REJECTION end subroutine process_mci_entry_generate_weighted_event module subroutine process_mci_entry_generate_unweighted_event & (mci_entry, mci_instance, mci_sampler) class(process_mci_entry_t), intent(inout) :: mci_entry class(mci_instance_t), intent(inout) :: mci_instance class(mci_sampler_t), intent(inout) :: mci_sampler call mci_entry%mci%generate_unweighted_event (mci_instance, mci_sampler) end subroutine process_mci_entry_generate_unweighted_event @ %def process_mci_entry_generate_weighted_event @ %def process_mci_entry_generate_unweighted_event @ Extract results. <>= procedure :: has_integral => process_mci_entry_has_integral procedure :: get_integral => process_mci_entry_get_integral procedure :: get_error => process_mci_entry_get_error procedure :: get_accuracy => process_mci_entry_get_accuracy procedure :: get_chi2 => process_mci_entry_get_chi2 procedure :: get_efficiency => process_mci_entry_get_efficiency <>= module function process_mci_entry_has_integral (mci_entry) result (flag) class(process_mci_entry_t), intent(in) :: mci_entry logical :: flag end function process_mci_entry_has_integral module function process_mci_entry_get_integral (mci_entry) result (integral) class(process_mci_entry_t), intent(in) :: mci_entry real(default) :: integral end function process_mci_entry_get_integral module function process_mci_entry_get_error (mci_entry) result (error) class(process_mci_entry_t), intent(in) :: mci_entry real(default) :: error end function process_mci_entry_get_error module function process_mci_entry_get_accuracy (mci_entry) result (accuracy) class(process_mci_entry_t), intent(in) :: mci_entry real(default) :: accuracy end function process_mci_entry_get_accuracy module function process_mci_entry_get_chi2 (mci_entry) result (chi2) class(process_mci_entry_t), intent(in) :: mci_entry real(default) :: chi2 end function process_mci_entry_get_chi2 module function process_mci_entry_get_efficiency & (mci_entry) result (efficiency) class(process_mci_entry_t), intent(in) :: mci_entry real(default) :: efficiency end function process_mci_entry_get_efficiency <>= module function process_mci_entry_has_integral (mci_entry) result (flag) class(process_mci_entry_t), intent(in) :: mci_entry logical :: flag flag = mci_entry%results%exist () end function process_mci_entry_has_integral module function process_mci_entry_get_integral (mci_entry) result (integral) class(process_mci_entry_t), intent(in) :: mci_entry real(default) :: integral integral = mci_entry%results%get_integral () end function process_mci_entry_get_integral module function process_mci_entry_get_error (mci_entry) result (error) class(process_mci_entry_t), intent(in) :: mci_entry real(default) :: error error = mci_entry%results%get_error () end function process_mci_entry_get_error module function process_mci_entry_get_accuracy (mci_entry) result (accuracy) class(process_mci_entry_t), intent(in) :: mci_entry real(default) :: accuracy accuracy = mci_entry%results%get_accuracy () end function process_mci_entry_get_accuracy module function process_mci_entry_get_chi2 (mci_entry) result (chi2) class(process_mci_entry_t), intent(in) :: mci_entry real(default) :: chi2 chi2 = mci_entry%results%get_chi2 () end function process_mci_entry_get_chi2 module function process_mci_entry_get_efficiency & (mci_entry) result (efficiency) class(process_mci_entry_t), intent(in) :: mci_entry real(default) :: efficiency efficiency = mci_entry%results%get_efficiency () end function process_mci_entry_get_efficiency @ %def process_mci_entry_get_integral process_mci_entry_get_error @ %def process_mci_entry_get_accuracy process_mci_entry_get_chi2 @ %def process_mci_entry_get_efficiency @ Return the MCI checksum. This may be the one used for configuration, but may also incorporate results, if they change the state of the integrator (adaptation). <>= procedure :: get_md5sum => process_mci_entry_get_md5sum <>= pure module function process_mci_entry_get_md5sum (entry) result (md5sum) class(process_mci_entry_t), intent(in) :: entry character(32) :: md5sum end function process_mci_entry_get_md5sum <>= pure module function process_mci_entry_get_md5sum (entry) result (md5sum) class(process_mci_entry_t), intent(in) :: entry character(32) :: md5sum md5sum = entry%mci%get_md5sum () end function process_mci_entry_get_md5sum @ %def process_mci_entry_get_md5sum @ \subsection{MC parameter set and MCI instance} For each process component that is associated with a multi-channel integration (MCI) object, the [[mci_work_t]] object contains the currently active parameter set. It also holds the implementation of the [[mci_instance_t]] that the integrator needs for doing its work. <>= public :: mci_work_t <>= type :: mci_work_t type(process_mci_entry_t), pointer :: config => null () real(default), dimension(:), allocatable :: x class(mci_instance_t), pointer :: mci => null () type(process_counter_t) :: counter logical :: keep_failed_events = .false. integer :: n_event_dropped = 0 contains <> end type mci_work_t @ %def mci_work_t @ First write configuration data, then the current values. <>= procedure :: write => mci_work_write <>= module subroutine mci_work_write (mci_work, unit, testflag) class(mci_work_t), intent(in) :: mci_work integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine mci_work_write <>= module subroutine mci_work_write (mci_work, unit, testflag) class(mci_work_t), intent(in) :: mci_work integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u, i u = given_output_unit (unit) write (u, "(1x,A,I0,A)") "Active MCI instance #", & mci_work%config%i_mci, " =" write (u, "(2x)", advance="no") do i = 1, mci_work%config%n_par write (u, "(1x,F7.5)", advance="no") mci_work%x(i) if (i == mci_work%config%n_par_sf) & write (u, "(1x,'|')", advance="no") end do write (u, *) if (associated (mci_work%mci)) then call mci_work%mci%write (u, pacify = testflag) call mci_work%counter%write (u) end if end subroutine mci_work_write @ %def mci_work_write @ The [[mci]] component may require finalization. <>= procedure :: final => mci_work_final <>= module subroutine mci_work_final (mci_work) class(mci_work_t), intent(inout) :: mci_work end subroutine mci_work_final <>= module subroutine mci_work_final (mci_work) class(mci_work_t), intent(inout) :: mci_work if (associated (mci_work%mci)) then call mci_work%mci%final () deallocate (mci_work%mci) end if end subroutine mci_work_final @ %def mci_work_final @ Initialize with the maximum length that we will need. Contents are not initialized. The integrator inside the [[mci_entry]] object is responsible for allocating and initializing its own instance, which is referred to by a pointer in the [[mci_work]] object. <>= procedure :: init => mci_work_init <>= module subroutine mci_work_init (mci_work, mci_entry) class(mci_work_t), intent(out) :: mci_work type(process_mci_entry_t), intent(in), target :: mci_entry end subroutine mci_work_init <>= module subroutine mci_work_init (mci_work, mci_entry) class(mci_work_t), intent(out) :: mci_work type(process_mci_entry_t), intent(in), target :: mci_entry mci_work%config => mci_entry allocate (mci_work%x (mci_entry%n_par)) if (allocated (mci_entry%mci)) then call mci_entry%mci%allocate_instance (mci_work%mci) call mci_work%mci%init (mci_entry%mci) end if end subroutine mci_work_init @ %def mci_work_init @ Set parameters explicitly, either all at once, or separately for the structure-function and process parts. <>= procedure :: set => mci_work_set procedure :: set_x_strfun => mci_work_set_x_strfun procedure :: set_x_process => mci_work_set_x_process <>= module subroutine mci_work_set (mci_work, x) class(mci_work_t), intent(inout) :: mci_work real(default), dimension(:), intent(in) :: x end subroutine mci_work_set module subroutine mci_work_set_x_strfun (mci_work, x) class(mci_work_t), intent(inout) :: mci_work real(default), dimension(:), intent(in) :: x end subroutine mci_work_set_x_strfun module subroutine mci_work_set_x_process (mci_work, x) class(mci_work_t), intent(inout) :: mci_work real(default), dimension(:), intent(in) :: x end subroutine mci_work_set_x_process <>= module subroutine mci_work_set (mci_work, x) class(mci_work_t), intent(inout) :: mci_work real(default), dimension(:), intent(in) :: x mci_work%x = x end subroutine mci_work_set module subroutine mci_work_set_x_strfun (mci_work, x) class(mci_work_t), intent(inout) :: mci_work real(default), dimension(:), intent(in) :: x mci_work%x(1 : mci_work%config%n_par_sf) = x end subroutine mci_work_set_x_strfun module subroutine mci_work_set_x_process (mci_work, x) class(mci_work_t), intent(inout) :: mci_work real(default), dimension(:), intent(in) :: x mci_work%x(mci_work%config%n_par_sf + 1 : mci_work%config%n_par) = x end subroutine mci_work_set_x_process @ %def mci_work_set @ %def mci_work_set_x_strfun @ %def mci_work_set_x_process @ Return the array of active components, i.e., those that correspond to the currently selected MC parameter set. <>= procedure :: get_active_components => mci_work_get_active_components <>= module function mci_work_get_active_components & (mci_work) result (i_component) class(mci_work_t), intent(in) :: mci_work integer, dimension(:), allocatable :: i_component end function mci_work_get_active_components <>= module function mci_work_get_active_components (mci_work) result (i_component) class(mci_work_t), intent(in) :: mci_work integer, dimension(:), allocatable :: i_component allocate (i_component (size (mci_work%config%i_component))) i_component = mci_work%config%i_component end function mci_work_get_active_components @ %def mci_work_get_active_components @ Return the active parameters as a simple array with correct length. Do this separately for the structure-function parameters and the process parameters. <>= procedure :: get_x_strfun => mci_work_get_x_strfun procedure :: get_x_process => mci_work_get_x_process <>= pure module function mci_work_get_x_strfun (mci_work) result (x) class(mci_work_t), intent(in) :: mci_work real(default), dimension(mci_work%config%n_par_sf) :: x end function mci_work_get_x_strfun pure module function mci_work_get_x_process (mci_work) result (x) class(mci_work_t), intent(in) :: mci_work real(default), dimension(mci_work%config%n_par_phs) :: x end function mci_work_get_x_process <>= pure module function mci_work_get_x_strfun (mci_work) result (x) class(mci_work_t), intent(in) :: mci_work real(default), dimension(mci_work%config%n_par_sf) :: x x = mci_work%x(1 : mci_work%config%n_par_sf) end function mci_work_get_x_strfun pure module function mci_work_get_x_process (mci_work) result (x) class(mci_work_t), intent(in) :: mci_work real(default), dimension(mci_work%config%n_par_phs) :: x x = mci_work%x(mci_work%config%n_par_sf + 1 : mci_work%config%n_par) end function mci_work_get_x_process @ %def mci_work_get_x_strfun @ %def mci_work_get_x_process @ Initialize and finalize event generation for the specified MCI entry. This also resets the counter. <>= procedure :: init_simulation => mci_work_init_simulation procedure :: final_simulation => mci_work_final_simulation <>= module subroutine mci_work_final_simulation (mci_work) class(mci_work_t), intent(inout) :: mci_work end subroutine mci_work_final_simulation module subroutine mci_work_init_simulation & (mci_work, safety_factor, keep_failed_events) class(mci_work_t), intent(inout) :: mci_work real(default), intent(in), optional :: safety_factor logical, intent(in), optional :: keep_failed_events end subroutine mci_work_init_simulation <>= module subroutine mci_work_init_simulation & (mci_work, safety_factor, keep_failed_events) class(mci_work_t), intent(inout) :: mci_work real(default), intent(in), optional :: safety_factor logical, intent(in), optional :: keep_failed_events call mci_work%mci%init_simulation (safety_factor) call mci_work%counter%reset () if (present (keep_failed_events)) & mci_work%keep_failed_events = keep_failed_events end subroutine mci_work_init_simulation module subroutine mci_work_final_simulation (mci_work) class(mci_work_t), intent(inout) :: mci_work call mci_work%mci%final_simulation () end subroutine mci_work_final_simulation @ %def mci_work_init_simulation @ %def mci_work_final_simulation @ Counter. <>= procedure :: reset_counter => mci_work_reset_counter procedure :: record_call => mci_work_record_call procedure :: get_counter => mci_work_get_counter <>= module subroutine mci_work_reset_counter (mci_work) class(mci_work_t), intent(inout) :: mci_work end subroutine mci_work_reset_counter module subroutine mci_work_record_call (mci_work, status) class(mci_work_t), intent(inout) :: mci_work integer, intent(in) :: status end subroutine mci_work_record_call pure module function mci_work_get_counter (mci_work) result (counter) class(mci_work_t), intent(in) :: mci_work type(process_counter_t) :: counter end function mci_work_get_counter <>= module subroutine mci_work_reset_counter (mci_work) class(mci_work_t), intent(inout) :: mci_work call mci_work%counter%reset () end subroutine mci_work_reset_counter module subroutine mci_work_record_call (mci_work, status) class(mci_work_t), intent(inout) :: mci_work integer, intent(in) :: status call mci_work%counter%record (status) end subroutine mci_work_record_call pure module function mci_work_get_counter (mci_work) result (counter) class(mci_work_t), intent(in) :: mci_work type(process_counter_t) :: counter counter = mci_work%counter end function mci_work_get_counter @ %def mci_work_reset_counter @ %def mci_work_record_call @ %def mci_work_get_counter @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process component manager} <<[[pcm.f90]]>>= <> module pcm <> <> use lorentz use model_data, only: model_data_t use models, only: model_t use quantum_numbers, only: quantum_numbers_t, quantum_numbers_mask_t use variables, only: var_list_t use nlo_data, only: nlo_settings_t use nlo_data, only: fks_template_t use nlo_data, only: FKS_DEFAULT, FKS_RESONANCES use mci_base, only: mci_t use phs_base, only: phs_config_t use mappings, only: mapping_defaults_t use phs_forests, only: phs_parameters_t use phs_fks, only: isr_kinematics_t, real_kinematics_t use phs_fks, only: phs_identifier_t use fks_regions, only: region_data_t use phs_fks, only: phs_fks_generator_t use phs_fks, only: dalitz_plot_t use phs_fks, only: phs_fks_config_t, get_filtered_resonance_histories use dispatch_phase_space, only: dispatch_phs use real_subtraction, only: real_subtraction_t, soft_mismatch_t use real_subtraction, only: INTEGRATION, FIXED_ORDER_EVENTS use real_subtraction, only: real_partition_t, powheg_damping_simple_t use real_subtraction, only: real_partition_fixed_order_t use virtual, only: virtual_t use dglap_remnant, only: dglap_remnant_t use blha_config, only: blha_master_t use pcm_base use process_config use process_mci, only: process_mci_entry_t use process_mci, only: REAL_SINGULAR, REAL_FINITE <> <> <> interface <> end interface contains <> end module pcm @ %def pcm @ <<[[pcm_sub.f90]]>>= <> submodule (pcm) pcm_s <> use constants, only: zero, two use diagnostics use phs_points, only: assignment(=) use io_units, only: free_unit use os_interface use process_constants, only: process_constants_t use physics_defs use flavors, only: flavor_t use interactions, only: interaction_t use dispatch_fks, only: dispatch_fks_setup use process_libraries, only: process_component_def_t use resonances, only: resonance_history_t, resonance_history_set_t use prc_threshold, only: threshold_def_t use blha_olp_interfaces, only: prc_blha_t implicit none contains <> end submodule pcm_s @ %def pcm_s @ \subsection{Default process component manager} This is the configuration object which has the duty of allocating the corresponding instance. The default version is trivial. <>= public :: pcm_default_t <>= type, extends (pcm_t) :: pcm_default_t contains <> end type pcm_default_t @ %def pcm_default_t Gfortran 7/8/9 bug, has to remain in the main module: <>= procedure :: allocate_workspace => pcm_default_allocate_workspace <>= subroutine pcm_default_allocate_workspace (pcm, work) class(pcm_default_t), intent(in) :: pcm class(pcm_workspace_t), intent(inout), allocatable :: work allocate (pcm_default_workspace_t :: work) end subroutine pcm_default_allocate_workspace @ %def pcm_default_allocate_workspace @ Finalizer: apply to core manager. <>= procedure :: final => pcm_default_final <>= module subroutine pcm_default_final (pcm) class(pcm_default_t), intent(inout) :: pcm end subroutine pcm_default_final <>= module subroutine pcm_default_final (pcm) class(pcm_default_t), intent(inout) :: pcm end subroutine pcm_default_final @ %def pcm_default_final @ <>= procedure :: is_nlo => pcm_default_is_nlo <>= module function pcm_default_is_nlo (pcm) result (is_nlo) logical :: is_nlo class(pcm_default_t), intent(in) :: pcm end function pcm_default_is_nlo <>= module function pcm_default_is_nlo (pcm) result (is_nlo) logical :: is_nlo class(pcm_default_t), intent(in) :: pcm is_nlo = .false. end function pcm_default_is_nlo @ %def pcm_default_is_nlo @ Initialize configuration data, using environment variables. <>= procedure :: init => pcm_default_init <>= module subroutine pcm_default_init (pcm, env, meta) class(pcm_default_t), intent(out) :: pcm type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta end subroutine pcm_default_init <>= module subroutine pcm_default_init (pcm, env, meta) class(pcm_default_t), intent(out) :: pcm type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta pcm%has_pdfs = env%has_pdfs () call pcm%set_blha_defaults & (env%has_polarized_beams (), env%get_var_list_ptr ()) pcm%os_data = env%get_os_data () end subroutine pcm_default_init @ %def pcm_default_init @ <>= type, extends (pcm_workspace_t) :: pcm_default_workspace_t contains <> end type pcm_default_workspace_t @ %def pcm_default_workspace_t @ <>= procedure :: final => pcm_default_workspace_final <>= module subroutine pcm_default_workspace_final (pcm_work) class(pcm_default_workspace_t), intent(inout) :: pcm_work end subroutine pcm_default_workspace_final <>= module subroutine pcm_default_workspace_final (pcm_work) class(pcm_default_workspace_t), intent(inout) :: pcm_work end subroutine pcm_default_workspace_final @ %def pcm_default_workspace_final @ <>= procedure :: is_nlo => pcm_default_workspace_is_nlo <>= module function pcm_default_workspace_is_nlo (pcm_work) result (is_nlo) logical :: is_nlo class(pcm_default_workspace_t), intent(inout) :: pcm_work end function pcm_default_workspace_is_nlo <>= module function pcm_default_workspace_is_nlo (pcm_work) result (is_nlo) logical :: is_nlo class(pcm_default_workspace_t), intent(inout) :: pcm_work is_nlo = .false. end function pcm_default_workspace_is_nlo @ %def pcm_default_workspace_is_nlo @ \subsection{Implementations for the default manager} Categorize components. Nothing to do here, all components are of Born type. <>= procedure :: categorize_components => pcm_default_categorize_components <>= module subroutine pcm_default_categorize_components (pcm, config) class(pcm_default_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config end subroutine pcm_default_categorize_components <>= module subroutine pcm_default_categorize_components (pcm, config) class(pcm_default_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config end subroutine pcm_default_categorize_components @ %def pcm_default_categorize_components @ \subsubsection{Phase-space configuration} Default setup for tree processes: a single phase-space configuration that is valid for all components. <>= procedure :: init_phs_config => pcm_default_init_phs_config <>= module subroutine pcm_default_init_phs_config & (pcm, phs_entry, meta, env, phs_par, mapping_defs) class(pcm_default_t), intent(inout) :: pcm type(process_phs_config_t), & dimension(:), allocatable, intent(out) :: phs_entry type(process_metadata_t), intent(in) :: meta type(process_environment_t), intent(in) :: env type(mapping_defaults_t), intent(in) :: mapping_defs type(phs_parameters_t), intent(in) :: phs_par end subroutine pcm_default_init_phs_config <>= module subroutine pcm_default_init_phs_config & (pcm, phs_entry, meta, env, phs_par, mapping_defs) class(pcm_default_t), intent(inout) :: pcm type(process_phs_config_t), & dimension(:), allocatable, intent(out) :: phs_entry type(process_metadata_t), intent(in) :: meta type(process_environment_t), intent(in) :: env type(mapping_defaults_t), intent(in) :: mapping_defs type(phs_parameters_t), intent(in) :: phs_par allocate (phs_entry (1)) allocate (pcm%i_phs_config (pcm%n_components), source=1) call dispatch_phs (phs_entry(1)%phs_config, & env%get_var_list_ptr (), & env%get_os_data (), & meta%id, & mapping_defs, phs_par) end subroutine pcm_default_init_phs_config @ %def pcm_default_init_phs_config @ \subsubsection{Core management} The default component manager assigns one core per component. We allocate and configure the core objects, using the process-component configuration data. <>= procedure :: allocate_cores => pcm_default_allocate_cores <>= module subroutine pcm_default_allocate_cores (pcm, config, core_entry) class(pcm_default_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry end subroutine pcm_default_allocate_cores <>= module subroutine pcm_default_allocate_cores (pcm, config, core_entry) class(pcm_default_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry type(process_component_def_t), pointer :: component_def integer :: i allocate (pcm%i_core (pcm%n_components), source = 0) pcm%n_cores = pcm%n_components allocate (core_entry (pcm%n_cores)) do i = 1, pcm%n_cores pcm%i_core(i) = i core_entry(i)%i_component = i component_def => config%process_def%get_component_def_ptr (i) core_entry(i)%core_def => component_def%get_core_def_ptr () core_entry(i)%active = component_def%can_be_integrated () end do end subroutine pcm_default_allocate_cores @ %def pcm_default_allocate_cores @ Extra code is required for certain core types (threshold) or if BLHA uses an external OLP (Born only, this case) for getting its matrix elements. <>= procedure :: prepare_any_external_code => & pcm_default_prepare_any_external_code <>= module subroutine pcm_default_prepare_any_external_code & (pcm, core_entry, i_core, libname, model, var_list) class(pcm_default_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry integer, intent(in) :: i_core type(string_t), intent(in) :: libname type(model_data_t), intent(in), target :: model type(var_list_t), intent(in) :: var_list end subroutine pcm_default_prepare_any_external_code <>= module subroutine pcm_default_prepare_any_external_code & (pcm, core_entry, i_core, libname, model, var_list) class(pcm_default_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry integer, intent(in) :: i_core type(string_t), intent(in) :: libname type(model_data_t), intent(in), target :: model type(var_list_t), intent(in) :: var_list if (core_entry%active) then associate (core => core_entry%core) if (core%needs_external_code ()) then call core%prepare_external_code & (core%data%flv_state, & var_list, pcm%os_data, libname, model, i_core, .false.) end if call core%set_equivalent_flv_hel_indices () end associate end if end subroutine pcm_default_prepare_any_external_code @ %def pcm_default_prepare_any_external_code @ Allocate and configure the BLHA record for a specific core, assuming that the core type requires it. In the default case, this is a Born configuration. <>= procedure :: setup_blha => pcm_default_setup_blha <>= module subroutine pcm_default_setup_blha (pcm, core_entry) class(pcm_default_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry end subroutine pcm_default_setup_blha <>= module subroutine pcm_default_setup_blha (pcm, core_entry) class(pcm_default_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry allocate (core_entry%blha_config, source = pcm%blha_defaults) call core_entry%blha_config%set_born () end subroutine pcm_default_setup_blha @ %def pcm_default_setup_blha @ Apply the configuration, using [[pcm]] data. <>= procedure :: prepare_blha_core => pcm_default_prepare_blha_core <>= module subroutine pcm_default_prepare_blha_core (pcm, core_entry, model) class(pcm_default_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry class(model_data_t), intent(in), target :: model end subroutine pcm_default_prepare_blha_core <>= module subroutine pcm_default_prepare_blha_core (pcm, core_entry, model) class(pcm_default_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry class(model_data_t), intent(in), target :: model integer :: n_in integer :: n_legs integer :: n_flv integer :: n_hel select type (core => core_entry%core) class is (prc_blha_t) associate (blha_config => core_entry%blha_config) n_in = core%data%n_in n_legs = core%data%get_n_tot () n_flv = core%data%n_flv n_hel = blha_config%get_n_hel (core%data%flv_state (1:n_in,1), model) call core%init_blha (blha_config, n_in, n_legs, n_flv, n_hel) call core%init_driver (pcm%os_data) end associate end select end subroutine pcm_default_prepare_blha_core @ %def pcm_default_prepare_blha_core @ Read the method settings from the variable list and store them in the BLHA master. This version: no NLO flag. <>= procedure :: set_blha_methods => pcm_default_set_blha_methods <>= module subroutine pcm_default_set_blha_methods (pcm, blha_master, var_list) class(pcm_default_t), intent(inout) :: pcm type(blha_master_t), intent(inout) :: blha_master type(var_list_t), intent(in) :: var_list end subroutine pcm_default_set_blha_methods <>= module subroutine pcm_default_set_blha_methods (pcm, blha_master, var_list) class(pcm_default_t), intent(inout) :: pcm type(blha_master_t), intent(inout) :: blha_master type(var_list_t), intent(in) :: var_list call blha_master%set_methods (.false., var_list) end subroutine pcm_default_set_blha_methods @ %def pcm_default_set_blha_methods @ Produce the LO and NLO flavor-state tables (as far as available), as appropriate for BLHA configuration. The default version looks at the first process core only, to get the Born data. (Multiple cores are thus unsupported.) The NLO flavor table is left unallocated. <>= procedure :: get_blha_flv_states => pcm_default_get_blha_flv_states <>= module subroutine pcm_default_get_blha_flv_states & (pcm, core_entry, flv_born, flv_real) class(pcm_default_t), intent(in) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry integer, dimension(:,:), allocatable, intent(out) :: flv_born integer, dimension(:,:), allocatable, intent(out) :: flv_real end subroutine pcm_default_get_blha_flv_states <>= module subroutine pcm_default_get_blha_flv_states & (pcm, core_entry, flv_born, flv_real) class(pcm_default_t), intent(in) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry integer, dimension(:,:), allocatable, intent(out) :: flv_born integer, dimension(:,:), allocatable, intent(out) :: flv_real flv_born = core_entry(1)%core%data%flv_state end subroutine pcm_default_get_blha_flv_states @ %def pcm_default_get_blha_flv_states @ Allocate and configure the MCI (multi-channel integrator) records. There is one record per active process component. Second procedure: call the MCI dispatcher with default-setup arguments. <>= procedure :: setup_mci => pcm_default_setup_mci procedure :: call_dispatch_mci => pcm_default_call_dispatch_mci <>= module subroutine pcm_default_setup_mci (pcm, mci_entry) class(pcm_default_t), intent(inout) :: pcm type(process_mci_entry_t), & dimension(:), allocatable, intent(out) :: mci_entry end subroutine pcm_default_setup_mci module subroutine pcm_default_call_dispatch_mci (pcm, & dispatch_mci, var_list, process_id, mci_template) class(pcm_default_t), intent(inout) :: pcm procedure(dispatch_mci_proc) :: dispatch_mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id class(mci_t), allocatable, intent(out) :: mci_template end subroutine pcm_default_call_dispatch_mci <>= module subroutine pcm_default_setup_mci (pcm, mci_entry) class(pcm_default_t), intent(inout) :: pcm type(process_mci_entry_t), & dimension(:), allocatable, intent(out) :: mci_entry class(mci_t), allocatable :: mci_template integer :: i, i_mci pcm%n_mci = count (pcm%component_active) allocate (pcm%i_mci (pcm%n_components), source = 0) i_mci = 0 do i = 1, pcm%n_components if (pcm%component_active(i)) then i_mci = i_mci + 1 pcm%i_mci(i) = i_mci end if end do allocate (mci_entry (pcm%n_mci)) end subroutine pcm_default_setup_mci module subroutine pcm_default_call_dispatch_mci (pcm, & dispatch_mci, var_list, process_id, mci_template) class(pcm_default_t), intent(inout) :: pcm procedure(dispatch_mci_proc) :: dispatch_mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id class(mci_t), allocatable, intent(out) :: mci_template call dispatch_mci (mci_template, var_list, process_id) end subroutine pcm_default_call_dispatch_mci @ %def pcm_default_setup_mci @ %def pcm_default_call_dispatch_mci @ Nothing left to do for the default algorithm. <>= procedure :: complete_setup => pcm_default_complete_setup <>= module subroutine pcm_default_complete_setup & (pcm, core_entry, component, model) class(pcm_default_t), intent(inout) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry type(process_component_t), dimension(:), intent(inout) :: component type(model_t), intent(in), target :: model end subroutine pcm_default_complete_setup <>= module subroutine pcm_default_complete_setup & (pcm, core_entry, component, model) class(pcm_default_t), intent(inout) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry type(process_component_t), dimension(:), intent(inout) :: component type(model_t), intent(in), target :: model end subroutine pcm_default_complete_setup @ %def pcm_default_complete_setup @ \subsubsection{Component management} Initialize a single component. We require all process-configuration blocks, and specific templates for the phase-space and integrator configuration. We also provide the current component index [[i]] and the [[active]] flag. In the default mode, all components are marked as master components. <>= procedure :: init_component => pcm_default_init_component <>= module subroutine pcm_default_init_component (pcm, component, i, active, & phs_config, env, meta, config) class(pcm_default_t), intent(in) :: pcm type(process_component_t), intent(out) :: component integer, intent(in) :: i logical, intent(in) :: active class(phs_config_t), allocatable, intent(in) :: phs_config type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta type(process_config_data_t), intent(in) :: config end subroutine pcm_default_init_component <>= module subroutine pcm_default_init_component (pcm, component, i, active, & phs_config, env, meta, config) class(pcm_default_t), intent(in) :: pcm type(process_component_t), intent(out) :: component integer, intent(in) :: i logical, intent(in) :: active class(phs_config_t), allocatable, intent(in) :: phs_config type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta type(process_config_data_t), intent(in) :: config call component%init (i, & env, meta, config, & active, & phs_config) component%component_type = COMP_MASTER end subroutine pcm_default_init_component @ %def pcm_default_init_component @ \subsection{NLO process component manager} The NLO-aware version of the process-component manager. This is the configuration object, which has the duty of allocating the corresponding instance. This is the nontrivial NLO version. <>= public :: pcm_nlo_t <>= type, extends (pcm_t) :: pcm_nlo_t type(string_t) :: id logical :: combined_integration = .false. logical :: vis_fks_regions = .false. integer, dimension(:), allocatable :: nlo_type integer, dimension(:), allocatable :: nlo_type_core integer, dimension(:), allocatable :: component_type integer :: i_born = 0 integer :: i_real = 0 integer :: i_sub = 0 type(nlo_settings_t) :: settings type(region_data_t) :: region_data logical :: use_real_partition = .false. logical :: use_real_singular = .false. real(default) :: real_partition_scale = 0 class(real_partition_t), allocatable :: real_partition type(dalitz_plot_t) :: dalitz_plot type(quantum_numbers_t), dimension(:,:), allocatable :: qn_real, qn_born contains <> end type pcm_nlo_t @ %def pcm_nlo_t @ Initialize configuration data, using environment variables. <>= procedure :: init => pcm_nlo_init <>= module subroutine pcm_nlo_init (pcm, env, meta) class(pcm_nlo_t), intent(out) :: pcm type(process_metadata_t), intent(in) :: meta type(process_environment_t), intent(in) :: env end subroutine pcm_nlo_init <>= module subroutine pcm_nlo_init (pcm, env, meta) class(pcm_nlo_t), intent(out) :: pcm type(process_metadata_t), intent(in) :: meta type(process_environment_t), intent(in) :: env type(var_list_t), pointer :: var_list type(fks_template_t) :: fks_template pcm%id = meta%id pcm%has_pdfs = env%has_pdfs () var_list => env%get_var_list_ptr () call dispatch_fks_setup (fks_template, var_list) call pcm%settings%init (var_list, fks_template) pcm%combined_integration = & var_list%get_lval (var_str ('?combined_nlo_integration')) select case (char (var_list%get_sval (var_str ("$real_partition_mode")))) case ("default", "off") pcm%use_real_partition = .false. pcm%use_real_singular = .false. case ("all", "on", "singular") pcm%use_real_partition = .true. pcm%use_real_singular = .true. case ("finite") pcm%use_real_partition = .true. pcm%use_real_singular = .false. case default call msg_fatal ("The real partition mode can only be " // & "default, off, all, on, singular or finite.") end select pcm%real_partition_scale = & var_list%get_rval (var_str ("real_partition_scale")) pcm%vis_fks_regions = & var_list%get_lval (var_str ("?vis_fks_regions")) call pcm%set_blha_defaults & (env%has_polarized_beams (), env%get_var_list_ptr ()) pcm%os_data = env%get_os_data () end subroutine pcm_nlo_init @ %def pcm_nlo_init @ Init/rewrite NLO settings without the FKS template. <>= procedure :: init_nlo_settings => pcm_nlo_init_nlo_settings <>= module subroutine pcm_nlo_init_nlo_settings (pcm, var_list) class(pcm_nlo_t), intent(inout) :: pcm type(var_list_t), intent(in), target :: var_list end subroutine pcm_nlo_init_nlo_settings <>= module subroutine pcm_nlo_init_nlo_settings (pcm, var_list) class(pcm_nlo_t), intent(inout) :: pcm type(var_list_t), intent(in), target :: var_list call pcm%settings%init (var_list) end subroutine pcm_nlo_init_nlo_settings @ %def pcm_nlo_init_nlo_settings @ As appropriate for the NLO/FKS algorithm, the category defined by the process, is called [[nlo_type]]. We refine this by setting the component category [[component_type]] separately. The component types [[COMP_MISMATCH]], [[COMP_PDF]], [[COMP_SUB]] are set only if the algorithm uses combined integration. Otherwise, they are set to [[COMP_DEFAULT]]. The component type [[COMP_REAL]] is further distinguished between [[COMP_REAL_SING]] or [[COMP_REAL_FIN]], if the algorithm uses real partitions. The former acts as a reference component for the latter, and we always assume that it is the first real component. Each component is assigned its own core. Exceptions: the finite-real component gets the same core as the singular-real component. The mismatch component gets the same core as the subtraction component. TODO wk 2018: this convention for real components can be improved. Check whether all component types should be assigned, not just for combined integration. <>= procedure :: categorize_components => pcm_nlo_categorize_components <>= module subroutine pcm_nlo_categorize_components (pcm, config) class(pcm_nlo_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config end subroutine pcm_nlo_categorize_components <>= module subroutine pcm_nlo_categorize_components (pcm, config) class(pcm_nlo_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config type(process_component_def_t), pointer :: component_def integer :: i allocate (pcm%nlo_type (pcm%n_components), source = COMPONENT_UNDEFINED) allocate (pcm%component_type (pcm%n_components), source = COMP_DEFAULT) do i = 1, pcm%n_components component_def => config%process_def%get_component_def_ptr (i) pcm%nlo_type(i) = component_def%get_nlo_type () if (pcm%combined_integration) then select case (pcm%nlo_type(i)) case (BORN) pcm%i_born = i pcm%component_type(i) = COMP_MASTER case (NLO_REAL) pcm%component_type(i) = COMP_REAL case (NLO_VIRTUAL) pcm%component_type(i) = COMP_VIRT case (NLO_MISMATCH) pcm%component_type(i) = COMP_MISMATCH case (NLO_DGLAP) pcm%component_type(i) = COMP_PDF case (NLO_SUBTRACTION) pcm%component_type(i) = COMP_SUB pcm%i_sub = i end select else select case (pcm%nlo_type(i)) case (BORN) pcm%i_born = i pcm%component_type(i) = COMP_MASTER case (NLO_REAL) pcm%component_type(i) = COMP_REAL case (NLO_VIRTUAL) pcm%component_type(i) = COMP_VIRT case (NLO_MISMATCH) pcm%component_type(i) = COMP_MISMATCH case (NLO_SUBTRACTION) pcm%i_sub = i end select end if end do call refine_real_type ( & pack ([(i, i=1, pcm%n_components)], & pcm%component_type==COMP_REAL)) contains subroutine refine_real_type (i_real) integer, dimension(:), intent(in) :: i_real pcm%i_real = i_real(1) if (pcm%use_real_partition) then pcm%component_type (i_real(1)) = COMP_REAL_SING pcm%component_type (i_real(2:)) = COMP_REAL_FIN end if end subroutine refine_real_type end subroutine pcm_nlo_categorize_components @ %def pcm_nlo_categorize_components @ \subsubsection{Phase-space initial configuration} Setup for the NLO/PHS processes: two phase-space configurations, (1) Born/wood, (2) real correction/FKS. All components use either one of these two configurations. TODO wk 2018: The [[first_real_component]] identifier is really ugly. Nothing should rely on the ordering. <>= procedure :: init_phs_config => pcm_nlo_init_phs_config <>= module subroutine pcm_nlo_init_phs_config & (pcm, phs_entry, meta, env, phs_par, mapping_defs) class(pcm_nlo_t), intent(inout) :: pcm type(process_phs_config_t), & dimension(:), allocatable, intent(out) :: phs_entry type(process_metadata_t), intent(in) :: meta type(process_environment_t), intent(in) :: env type(mapping_defaults_t), intent(in) :: mapping_defs type(phs_parameters_t), intent(in) :: phs_par end subroutine pcm_nlo_init_phs_config <>= module subroutine pcm_nlo_init_phs_config & (pcm, phs_entry, meta, env, phs_par, mapping_defs) class(pcm_nlo_t), intent(inout) :: pcm type(process_phs_config_t), & dimension(:), allocatable, intent(out) :: phs_entry type(process_metadata_t), intent(in) :: meta type(process_environment_t), intent(in) :: env type(mapping_defaults_t), intent(in) :: mapping_defs type(phs_parameters_t), intent(in) :: phs_par integer :: i logical :: first_real_component allocate (phs_entry (2)) call dispatch_phs (phs_entry(1)%phs_config, & env%get_var_list_ptr (), & env%get_os_data (), & meta%id, & mapping_defs, phs_par, & var_str ("wood")) call dispatch_phs (phs_entry(2)%phs_config, & env%get_var_list_ptr (), & env%get_os_data (), & meta%id, & mapping_defs, phs_par, & var_str ("fks")) allocate (pcm%i_phs_config (pcm%n_components), source=0) first_real_component = .true. do i = 1, pcm%n_components select case (pcm%nlo_type(i)) case (BORN, NLO_VIRTUAL, NLO_SUBTRACTION) pcm%i_phs_config(i) = 1 case (NLO_REAL) if (pcm%use_real_partition) then if (pcm%use_real_singular) then if (first_real_component) then pcm%i_phs_config(i) = 2 first_real_component = .false. else pcm%i_phs_config(i) = 1 end if else pcm%i_phs_config(i) = 1 end if else pcm%i_phs_config(i) = 2 end if case (NLO_MISMATCH, NLO_DGLAP, GKS) pcm%i_phs_config(i) = 2 end select end do end subroutine pcm_nlo_init_phs_config @ %def pcm_nlo_init_phs_config @ \subsubsection{Core management} Allocate the core (matrix-element interface) objects that we will need for evaluation. Every component gets an associated core, except for the real-finite and mismatch components (if any). Those components are associated with their previous corresponding real-singular and subtraction cores, respectively. After cores are allocated, configure the region-data block that is maintained by the NLO process-component manager. <>= procedure :: allocate_cores => pcm_nlo_allocate_cores <>= module subroutine pcm_nlo_allocate_cores (pcm, config, core_entry) class(pcm_nlo_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry end subroutine pcm_nlo_allocate_cores <>= module subroutine pcm_nlo_allocate_cores (pcm, config, core_entry) class(pcm_nlo_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry type(process_component_def_t), pointer :: component_def integer :: i, i_core allocate (pcm%i_core (pcm%n_components), source = 0) pcm%n_cores = pcm%n_components & - count (pcm%component_type(:) == COMP_REAL_FIN) & - count (pcm%component_type(:) == COMP_MISMATCH) allocate (core_entry (pcm%n_cores)) allocate (pcm%nlo_type_core (pcm%n_cores), source = BORN) i_core = 0 do i = 1, pcm%n_components select case (pcm%component_type(i)) case default i_core = i_core + 1 pcm%i_core(i) = i_core pcm%nlo_type_core(i_core) = pcm%nlo_type(i) core_entry(i_core)%i_component = i component_def => config%process_def%get_component_def_ptr (i) core_entry(i_core)%core_def => component_def%get_core_def_ptr () select case (pcm%nlo_type(i)) case default core_entry(i)%active = component_def%can_be_integrated () case (NLO_REAL, NLO_SUBTRACTION) core_entry(i)%active = .true. end select case (COMP_REAL_FIN) pcm%i_core(i) = pcm%i_core(pcm%i_real) case (COMP_MISMATCH) pcm%i_core(i) = pcm%i_core(pcm%i_sub) end select end do end subroutine pcm_nlo_allocate_cores @ %def pcm_nlo_allocate_cores @ Extra code is required for certain core types (threshold) or if BLHA uses an external OLP for getting its matrix elements. OMega matrix elements, by definition, do not need extra code. NLO-virtual or subtraction matrix elements always need extra code. More precisely: for the Born and virtual matrix element, the extra code is accessed only if the component is active. The radiation (real) and the subtraction corrections (singular and finite), extra code is accessed in any case. The flavor state is taken from the [[region_data]] table in the [[pcm]] record. We use the Born and real flavor-state tables as appropriate. <>= procedure :: prepare_any_external_code => & pcm_nlo_prepare_any_external_code <>= module subroutine pcm_nlo_prepare_any_external_code & (pcm, core_entry, i_core, libname, model, var_list) class(pcm_nlo_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry integer, intent(in) :: i_core type(string_t), intent(in) :: libname type(model_data_t), intent(in), target :: model type(var_list_t), intent(in) :: var_list end subroutine pcm_nlo_prepare_any_external_code <>= module subroutine pcm_nlo_prepare_any_external_code & (pcm, core_entry, i_core, libname, model, var_list) class(pcm_nlo_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry integer, intent(in) :: i_core type(string_t), intent(in) :: libname type(model_data_t), intent(in), target :: model type(var_list_t), intent(in) :: var_list integer, dimension(:,:), allocatable :: flv_born, flv_real integer :: i call pcm%region_data%get_all_flv_states (flv_born, flv_real) if (core_entry%active) then associate (core => core_entry%core) if (core%needs_external_code ()) then select case (pcm%nlo_type (core_entry%i_component)) case default call core%data%set_flv_state (flv_born) case (NLO_REAL) call core%data%set_flv_state (flv_real) end select call core%prepare_external_code & (core%data%flv_state, & var_list, pcm%os_data, libname, model, i_core, .true.) end if call core%set_equivalent_flv_hel_indices () end associate end if end subroutine pcm_nlo_prepare_any_external_code @ %def pcm_nlo_prepare_any_external_code @ Allocate and configure the BLHA record for a specific core, assuming that the core type requires it. The configuration depends on the NLO type of the core. <>= procedure :: setup_blha => pcm_nlo_setup_blha <>= module subroutine pcm_nlo_setup_blha (pcm, core_entry) class(pcm_nlo_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry end subroutine pcm_nlo_setup_blha <>= module subroutine pcm_nlo_setup_blha (pcm, core_entry) class(pcm_nlo_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry allocate (core_entry%blha_config, source = pcm%blha_defaults) select case (pcm%nlo_type(core_entry%i_component)) case (BORN) call core_entry%blha_config%set_born () case (NLO_REAL) call core_entry%blha_config%set_real_trees () case (NLO_VIRTUAL) call core_entry%blha_config%set_loop () case (NLO_SUBTRACTION) call core_entry%blha_config%set_subtraction () call core_entry%blha_config%set_internal_color_correlations () case (NLO_DGLAP) call core_entry%blha_config%set_dglap () end select end subroutine pcm_nlo_setup_blha @ %def pcm_nlo_setup_blha @ After phase-space configuration data and core entries are available, we fill tables and compute the remaining NLO data that will steer the integration and subtraction algorithm. There are three parts: recognize a threshold-type process core (if it exists), prepare the region-data tables (always), and prepare for real partitioning (if requested). The real-component phase space acts as the source for resonance-history information, required for the region data. <>= procedure :: complete_setup => pcm_nlo_complete_setup <>= module subroutine pcm_nlo_complete_setup (pcm, core_entry, component, model) class(pcm_nlo_t), intent(inout) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry type(process_component_t), dimension(:), intent(inout) :: component type(model_t), intent(in), target :: model end subroutine pcm_nlo_complete_setup <>= module subroutine pcm_nlo_complete_setup (pcm, core_entry, component, model) class(pcm_nlo_t), intent(inout) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry type(process_component_t), dimension(:), intent(inout) :: component type(model_t), intent(in), target :: model integer :: alpha_power, alphas_power call pcm%handle_threshold_core (core_entry) call component(1)%config%get_coupling_powers (alpha_power, alphas_power) call pcm%setup_region_data (core_entry, & component(pcm%i_real)%phs_config, model, alpha_power, alphas_power) call pcm%setup_real_partition () end subroutine pcm_nlo_complete_setup @ %def pcm_nlo_complete_setup @ Apply the BLHA configuration to a core object, using the region data from [[pcm]] for determining the particle content. <>= procedure :: prepare_blha_core => pcm_nlo_prepare_blha_core <>= module subroutine pcm_nlo_prepare_blha_core (pcm, core_entry, model) class(pcm_nlo_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry class(model_data_t), intent(in), target :: model end subroutine pcm_nlo_prepare_blha_core <>= module subroutine pcm_nlo_prepare_blha_core (pcm, core_entry, model) class(pcm_nlo_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry class(model_data_t), intent(in), target :: model integer :: n_in integer :: n_legs integer :: n_flv integer :: n_hel select type (core => core_entry%core) class is (prc_blha_t) associate (blha_config => core_entry%blha_config) n_in = core%data%n_in select case (pcm%nlo_type(core_entry%i_component)) case (NLO_REAL) n_legs = pcm%region_data%get_n_legs_real () n_flv = pcm%region_data%get_n_flv_real () case default n_legs = pcm%region_data%get_n_legs_born () n_flv = pcm%region_data%get_n_flv_born () end select n_hel = blha_config%get_n_hel (core%data%flv_state (1:n_in,1), model) call core%init_blha (blha_config, n_in, n_legs, n_flv, n_hel) call core%init_driver (pcm%os_data) end associate end select end subroutine pcm_nlo_prepare_blha_core @ %def pcm_nlo_prepare_blha_core @ Read the method settings from the variable list and store them in the BLHA master. This version: NLO flag set. <>= procedure :: set_blha_methods => pcm_nlo_set_blha_methods <>= module subroutine pcm_nlo_set_blha_methods (pcm, blha_master, var_list) class(pcm_nlo_t), intent(inout) :: pcm type(blha_master_t), intent(inout) :: blha_master type(var_list_t), intent(in) :: var_list end subroutine pcm_nlo_set_blha_methods <>= module subroutine pcm_nlo_set_blha_methods (pcm, blha_master, var_list) class(pcm_nlo_t), intent(inout) :: pcm type(blha_master_t), intent(inout) :: blha_master type(var_list_t), intent(in) :: var_list call blha_master%set_methods (.true., var_list) call pcm%blha_defaults%set_loop_method (blha_master) end subroutine pcm_nlo_set_blha_methods @ %def pcm_nlo_set_blha_methods @ Produce the LO and NLO flavor-state tables (as far as available), as appropriate for BLHA configuration. The NLO version copies the tables from the region data inside [[pcm]]. The core array is not needed. <>= procedure :: get_blha_flv_states => pcm_nlo_get_blha_flv_states <>= module subroutine pcm_nlo_get_blha_flv_states & (pcm, core_entry, flv_born, flv_real) class(pcm_nlo_t), intent(in) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry integer, dimension(:,:), allocatable, intent(out) :: flv_born integer, dimension(:,:), allocatable, intent(out) :: flv_real end subroutine pcm_nlo_get_blha_flv_states <>= module subroutine pcm_nlo_get_blha_flv_states & (pcm, core_entry, flv_born, flv_real) class(pcm_nlo_t), intent(in) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry integer, dimension(:,:), allocatable, intent(out) :: flv_born integer, dimension(:,:), allocatable, intent(out) :: flv_real call pcm%region_data%get_all_flv_states (flv_born, flv_real) end subroutine pcm_nlo_get_blha_flv_states @ %def pcm_nlo_get_blha_flv_states @ Allocate and configure the MCI (multi-channel integrator) records. The relation depends on the [[combined_integration]] setting. If we integrate components separately, each component gets its own record, except for the subtraction component. If we do the combination, there is one record for the master (Born) component and a second one for the real-finite component, if present. Each entry acquires some NLO-specific initialization. Generic configuration follows later. Second procedure: call the MCI dispatcher with NLO-setup arguments. <>= procedure :: setup_mci => pcm_nlo_setup_mci procedure :: call_dispatch_mci => pcm_nlo_call_dispatch_mci <>= module subroutine pcm_nlo_setup_mci (pcm, mci_entry) class(pcm_nlo_t), intent(inout) :: pcm type(process_mci_entry_t), & dimension(:), allocatable, intent(out) :: mci_entry end subroutine pcm_nlo_setup_mci module subroutine pcm_nlo_call_dispatch_mci (pcm, & dispatch_mci, var_list, process_id, mci_template) class(pcm_nlo_t), intent(inout) :: pcm procedure(dispatch_mci_proc) :: dispatch_mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id class(mci_t), allocatable, intent(out) :: mci_template end subroutine pcm_nlo_call_dispatch_mci <>= module subroutine pcm_nlo_setup_mci (pcm, mci_entry) class(pcm_nlo_t), intent(inout) :: pcm type(process_mci_entry_t), & dimension(:), allocatable, intent(out) :: mci_entry class(mci_t), allocatable :: mci_template integer :: i, i_mci if (pcm%combined_integration) then pcm%n_mci = 1 & + count (pcm%component_active(:) & & .and. pcm%component_type(:) == COMP_REAL_FIN) allocate (pcm%i_mci (pcm%n_components), source = 0) do i = 1, pcm%n_components if (pcm%component_active(i)) then select case (pcm%component_type(i)) case (COMP_MASTER) pcm%i_mci(i) = 1 case (COMP_REAL_FIN) pcm%i_mci(i) = 2 end select end if end do else pcm%n_mci = count (pcm%component_active(:) & & .and. pcm%nlo_type(:) /= NLO_SUBTRACTION) allocate (pcm%i_mci (pcm%n_components), source = 0) i_mci = 0 do i = 1, pcm%n_components if (pcm%component_active(i)) then select case (pcm%nlo_type(i)) case default i_mci = i_mci + 1 pcm%i_mci(i) = i_mci case (NLO_SUBTRACTION) end select end if end do end if allocate (mci_entry (pcm%n_mci)) mci_entry(:)%combined_integration = pcm%combined_integration if (pcm%use_real_partition) then do i = 1, pcm%n_components i_mci = pcm%i_mci(i) if (i_mci > 0) then select case (pcm%component_type(i)) case (COMP_REAL_FIN) mci_entry(i_mci)%real_partition_type = REAL_FINITE case default mci_entry(i_mci)%real_partition_type = REAL_SINGULAR end select end if end do end if end subroutine pcm_nlo_setup_mci module subroutine pcm_nlo_call_dispatch_mci (pcm, & dispatch_mci, var_list, process_id, mci_template) class(pcm_nlo_t), intent(inout) :: pcm procedure(dispatch_mci_proc) :: dispatch_mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id class(mci_t), allocatable, intent(out) :: mci_template call dispatch_mci (mci_template, var_list, process_id, is_nlo = .true.) end subroutine pcm_nlo_call_dispatch_mci @ %def pcm_nlo_setup_mci @ %def pcm_nlo_call_dispatch_mci @ Check for a threshold core and adjust the configuration accordingly, before singular region data are considered. <>= procedure :: handle_threshold_core => pcm_nlo_handle_threshold_core <>= module subroutine pcm_nlo_handle_threshold_core (pcm, core_entry) class(pcm_nlo_t), intent(inout) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry end subroutine pcm_nlo_handle_threshold_core <>= module subroutine pcm_nlo_handle_threshold_core (pcm, core_entry) class(pcm_nlo_t), intent(inout) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry integer :: i do i = 1, size (core_entry) select type (core => core_entry(i)%core_def) type is (threshold_def_t) pcm%settings%factorization_mode = FACTORIZATION_THRESHOLD return end select end do end subroutine pcm_nlo_handle_threshold_core @ %def pcm_nlo_handle_threshold_core @ Configure the singular-region tables based on the process data for the Born and Real (singular) cores, using also the appropriate FKS phase-space configuration object. In passing, we may create a table of resonance histories that are relevant for the singular-region configuration. TODO wk 2018: check whether [[phs_entry]] needs to be intent(inout). <>= procedure :: setup_region_data => pcm_nlo_setup_region_data <>= module subroutine pcm_nlo_setup_region_data & (pcm, core_entry, phs_config, model, alpha_power, alphas_power) class(pcm_nlo_t), intent(inout) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry class(phs_config_t), intent(inout) :: phs_config type(model_t), intent(in), target :: model integer, intent(in) :: alpha_power, alphas_power end subroutine pcm_nlo_setup_region_data <>= module subroutine pcm_nlo_setup_region_data & (pcm, core_entry, phs_config, model, alpha_power, alphas_power) class(pcm_nlo_t), intent(inout) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry class(phs_config_t), intent(inout) :: phs_config type(model_t), intent(in), target :: model integer, intent(in) :: alpha_power, alphas_power type(process_constants_t) :: data_born, data_real integer, dimension (:,:), allocatable :: flavor_born, flavor_real type(resonance_history_t), dimension(:), allocatable :: resonance_histories type(var_list_t), pointer :: var_list logical :: success data_born = core_entry(pcm%i_core(pcm%i_born))%core%data data_real = core_entry(pcm%i_core(pcm%i_real))%core%data call data_born%get_flv_state (flavor_born) call data_real%get_flv_state (flavor_real) call pcm%region_data%init & (data_born%n_in, model, flavor_born, flavor_real, & pcm%settings%nlo_correction_type, alpha_power, alphas_power) associate (template => pcm%settings%fks_template) if (template%mapping_type == FKS_RESONANCES) then select type (phs_config) type is (phs_fks_config_t) call get_filtered_resonance_histories (phs_config, & data_born%n_in, flavor_born, model, & template%excluded_resonances, & resonance_histories, success) end select if (.not. success) template%mapping_type = FKS_DEFAULT end if call pcm%region_data%setup_fks_mappings (template, data_born%n_in) !!! Check again, mapping_type might have changed if (template%mapping_type == FKS_RESONANCES) then call pcm%region_data%set_resonance_mappings (resonance_histories) call pcm%region_data%init_resonance_information () pcm%settings%use_resonance_mappings = .true. end if end associate if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) then call pcm%region_data%set_isr_pseudo_regions () call pcm%region_data%split_up_interference_regions_for_threshold () end if call pcm%region_data%compute_number_of_phase_spaces () call pcm%region_data%set_i_phs_to_i_con () call pcm%region_data%write_to_file & (pcm%id, pcm%vis_fks_regions, pcm%os_data) if (debug_active (D_SUBTRACTION)) & call pcm%region_data%check_consistency (.true.) end subroutine pcm_nlo_setup_region_data @ %def pcm_nlo_setup_region_data @ After region data are set up, we allocate and configure the [[real_partition]] objects, if requested. Gfortran 7/8/9 bug, has to remain in the main module: <>= procedure :: setup_real_partition => pcm_nlo_setup_real_partition <>= subroutine pcm_nlo_setup_real_partition (pcm) class(pcm_nlo_t), intent(inout) :: pcm if (pcm%use_real_partition) then if (.not. allocated (pcm%real_partition)) then allocate (real_partition_fixed_order_t :: pcm%real_partition) select type (partition => pcm%real_partition) type is (real_partition_fixed_order_t) call pcm%region_data%get_all_ftuples (partition%fks_pairs) partition%scale = pcm%real_partition_scale end select end if end if end subroutine pcm_nlo_setup_real_partition @ %def pcm_nlo_setup_real_partition @ Initialize a single component. We require all process-configuration blocks, and specific templates for the phase-space and integrator configuration. We also provide the current component index [[i]] and the [[active]] flag. For a subtraction component, the [[active]] flag is overridden. In the nlo mode, the component types have been determined before. TODO wk 2018: the component type need not be stored in the component; we may remove this when everything is controlled by [[pcm]]. <>= procedure :: init_component => pcm_nlo_init_component <>= module subroutine pcm_nlo_init_component (pcm, component, i, active, & phs_config, env, meta, config) class(pcm_nlo_t), intent(in) :: pcm type(process_component_t), intent(out) :: component integer, intent(in) :: i logical, intent(in) :: active class(phs_config_t), allocatable, intent(in) :: phs_config type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta type(process_config_data_t), intent(in) :: config end subroutine pcm_nlo_init_component <>= module subroutine pcm_nlo_init_component (pcm, component, i, active, & phs_config, env, meta, config) class(pcm_nlo_t), intent(in) :: pcm type(process_component_t), intent(out) :: component integer, intent(in) :: i logical, intent(in) :: active class(phs_config_t), allocatable, intent(in) :: phs_config type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta type(process_config_data_t), intent(in) :: config logical :: activate select case (pcm%nlo_type(i)) case default; activate = active case (NLO_SUBTRACTION); activate = .false. end select call component%init (i, & env, meta, config, & activate, & phs_config) component%component_type = pcm%component_type(i) end subroutine pcm_nlo_init_component @ %def pcm_nlo_init_component @ Override the base method: record the active components in the PCM object, and report inactive components (except for the subtraction component). <>= procedure :: record_inactive_components => pcm_nlo_record_inactive_components <>= module subroutine pcm_nlo_record_inactive_components (pcm, component, meta) class(pcm_nlo_t), intent(inout) :: pcm type(process_component_t), dimension(:), intent(in) :: component type(process_metadata_t), intent(inout) :: meta end subroutine pcm_nlo_record_inactive_components <>= module subroutine pcm_nlo_record_inactive_components (pcm, component, meta) class(pcm_nlo_t), intent(inout) :: pcm type(process_component_t), dimension(:), intent(in) :: component type(process_metadata_t), intent(inout) :: meta integer :: i pcm%component_active = component%active do i = 1, pcm%n_components select case (pcm%nlo_type(i)) case (NLO_SUBTRACTION) case default if (.not. component(i)%active) call meta%deactivate_component (i) end select end do end subroutine pcm_nlo_record_inactive_components @ %def pcm_nlo_record_inactive_components @ <>= procedure :: core_is_radiation => pcm_nlo_core_is_radiation <>= module function pcm_nlo_core_is_radiation (pcm, i_core) result (is_rad) logical :: is_rad class(pcm_nlo_t), intent(in) :: pcm integer, intent(in) :: i_core end function pcm_nlo_core_is_radiation <>= module function pcm_nlo_core_is_radiation (pcm, i_core) result (is_rad) logical :: is_rad class(pcm_nlo_t), intent(in) :: pcm integer, intent(in) :: i_core is_rad = pcm%nlo_type(i_core) == NLO_REAL ! .and. .not. pcm%cm%sub(i_core) end function pcm_nlo_core_is_radiation @ %def pcm_nlo_core_is_radiation @ <>= procedure :: get_n_flv_born => pcm_nlo_get_n_flv_born <>= module function pcm_nlo_get_n_flv_born (pcm_nlo) result (n_flv) integer :: n_flv class(pcm_nlo_t), intent(in) :: pcm_nlo end function pcm_nlo_get_n_flv_born <>= module function pcm_nlo_get_n_flv_born (pcm_nlo) result (n_flv) integer :: n_flv class(pcm_nlo_t), intent(in) :: pcm_nlo n_flv = pcm_nlo%region_data%n_flv_born end function pcm_nlo_get_n_flv_born @ %def pcm_nlo_get_n_flv_born @ <>= procedure :: get_n_flv_real => pcm_nlo_get_n_flv_real <>= module function pcm_nlo_get_n_flv_real (pcm_nlo) result (n_flv) integer :: n_flv class(pcm_nlo_t), intent(in) :: pcm_nlo end function pcm_nlo_get_n_flv_real <>= module function pcm_nlo_get_n_flv_real (pcm_nlo) result (n_flv) integer :: n_flv class(pcm_nlo_t), intent(in) :: pcm_nlo n_flv = pcm_nlo%region_data%n_flv_real end function pcm_nlo_get_n_flv_real @ %def pcm_nlo_get_n_flv_real @ <>= procedure :: get_n_alr => pcm_nlo_get_n_alr <>= module function pcm_nlo_get_n_alr (pcm) result (n_alr) integer :: n_alr class(pcm_nlo_t), intent(in) :: pcm end function pcm_nlo_get_n_alr <>= module function pcm_nlo_get_n_alr (pcm) result (n_alr) integer :: n_alr class(pcm_nlo_t), intent(in) :: pcm n_alr = pcm%region_data%n_regions end function pcm_nlo_get_n_alr @ %def pcm_nlo_get_n_alr @ <>= procedure :: get_flv_states => pcm_nlo_get_flv_states <>= module function pcm_nlo_get_flv_states (pcm, born) result (flv) integer, dimension(:,:), allocatable :: flv class(pcm_nlo_t), intent(in) :: pcm logical, intent(in) :: born end function pcm_nlo_get_flv_states <>= module function pcm_nlo_get_flv_states (pcm, born) result (flv) integer, dimension(:,:), allocatable :: flv class(pcm_nlo_t), intent(in) :: pcm logical, intent(in) :: born if (born) then flv = pcm%region_data%get_flv_states_born () else flv = pcm%region_data%get_flv_states_real () end if end function pcm_nlo_get_flv_states @ %def pcm_nlo_get_flv_states @ <>= procedure :: get_qn => pcm_nlo_get_qn <>= module function pcm_nlo_get_qn (pcm, born) result (qn) type(quantum_numbers_t), dimension(:,:), allocatable :: qn class(pcm_nlo_t), intent(in) :: pcm logical, intent(in) :: born end function pcm_nlo_get_qn <>= module function pcm_nlo_get_qn (pcm, born) result (qn) type(quantum_numbers_t), dimension(:,:), allocatable :: qn class(pcm_nlo_t), intent(in) :: pcm logical, intent(in) :: born if (born) then qn = pcm%qn_born else qn = pcm%qn_real end if end function pcm_nlo_get_qn @ %def pcm_nlo_get_qn @ Check if there are massive emitters. Since the mass-structure of all underlying Born configurations have to be the same (\textbf{This does not have to be the case when different components are generated at LO}) , we just use the first one to determine this. <>= procedure :: has_massive_emitter => pcm_nlo_has_massive_emitter <>= module function pcm_nlo_has_massive_emitter (pcm) result (val) logical :: val class(pcm_nlo_t), intent(in) :: pcm end function pcm_nlo_has_massive_emitter <>= module function pcm_nlo_has_massive_emitter (pcm) result (val) logical :: val class(pcm_nlo_t), intent(in) :: pcm integer :: i val = .false. associate (reg_data => pcm%region_data) do i = reg_data%n_in + 1, reg_data%n_legs_born if (any (i == reg_data%emitters)) & val = val .or. reg_data%flv_born(1)%massive(i) end do end associate end function pcm_nlo_has_massive_emitter @ %def pcm_nlo_has_massive_emitter @ Returns an array which specifies if the particle at position [[i]] is massive. <>= procedure :: get_mass_info => pcm_nlo_get_mass_info <>= module function pcm_nlo_get_mass_info (pcm, i_flv) result (massive) class(pcm_nlo_t), intent(in) :: pcm integer, intent(in) :: i_flv logical, dimension(:), allocatable :: massive end function pcm_nlo_get_mass_info <>= module function pcm_nlo_get_mass_info (pcm, i_flv) result (massive) class(pcm_nlo_t), intent(in) :: pcm integer, intent(in) :: i_flv logical, dimension(:), allocatable :: massive allocate (massive (size (pcm%region_data%flv_born(i_flv)%massive))) massive = pcm%region_data%flv_born(i_flv)%massive end function pcm_nlo_get_mass_info @ %def pcm_nlo_get_mass_info @ Gfortran 7/8/9 bug, has to remain in the main module: <>= procedure :: allocate_workspace => pcm_nlo_allocate_workspace <>= subroutine pcm_nlo_allocate_workspace (pcm, work) class(pcm_nlo_t), intent(in) :: pcm class(pcm_workspace_t), intent(inout), allocatable :: work allocate (pcm_nlo_workspace_t :: work) end subroutine pcm_nlo_allocate_workspace @ %def pcm_nlo_allocate_workspace @ <>= procedure :: init_qn => pcm_nlo_init_qn <>= module subroutine pcm_nlo_init_qn (pcm, model) class(pcm_nlo_t), intent(inout) :: pcm class(model_data_t), intent(in) :: model end subroutine pcm_nlo_init_qn <>= module subroutine pcm_nlo_init_qn (pcm, model) class(pcm_nlo_t), intent(inout) :: pcm class(model_data_t), intent(in) :: model integer, dimension(:,:), allocatable :: flv_states type(flavor_t), dimension(:), allocatable :: flv integer :: i type(quantum_numbers_t), dimension(:), allocatable :: qn allocate (flv_states (pcm%region_data%n_legs_born, & pcm%region_data%n_flv_born)) flv_states = pcm%get_flv_states (.true.) allocate (pcm%qn_born (size (flv_states, dim = 1), & size (flv_states, dim = 2))) allocate (flv (size (flv_states, dim = 1))) allocate (qn (size (flv_states, dim = 1))) do i = 1, pcm%get_n_flv_born () call flv%init (flv_states (:,i), model) call qn%init (flv) pcm%qn_born(:,i) = qn end do deallocate (flv); deallocate (qn) deallocate (flv_states) allocate (flv_states (pcm%region_data%n_legs_real, pcm%region_data%n_flv_real)) flv_states = pcm%get_flv_states (.false.) allocate (pcm%qn_real (size (flv_states, dim = 1), size (flv_states, dim = 2))) allocate (flv (size (flv_states, dim = 1))) allocate (qn (size (flv_states, dim = 1))) do i = 1, pcm%get_n_flv_real () call flv%init (flv_states (:,i), model) call qn%init (flv) pcm%qn_real(:,i) = qn end do end subroutine pcm_nlo_init_qn @ %def pcm_nlo_init_qn @ Gfortran 7/8/9 bug, has to remain in the main module: <>= procedure :: allocate_ps_matching => pcm_nlo_allocate_ps_matching <>= subroutine pcm_nlo_allocate_ps_matching (pcm) class(pcm_nlo_t), intent(inout) :: pcm if (.not. allocated (pcm%real_partition)) then allocate (powheg_damping_simple_t :: pcm%real_partition) end if end subroutine pcm_nlo_allocate_ps_matching @ %def pcm_nlo_allocate_ps_matching @ <>= procedure :: activate_dalitz_plot => pcm_nlo_activate_dalitz_plot <>= module subroutine pcm_nlo_activate_dalitz_plot (pcm, filename) class(pcm_nlo_t), intent(inout) :: pcm type(string_t), intent(in) :: filename end subroutine pcm_nlo_activate_dalitz_plot <>= module subroutine pcm_nlo_activate_dalitz_plot (pcm, filename) class(pcm_nlo_t), intent(inout) :: pcm type(string_t), intent(in) :: filename call pcm%dalitz_plot%init (free_unit (), filename, .false.) call pcm%dalitz_plot%write_header () end subroutine pcm_nlo_activate_dalitz_plot @ %def pcm_nlo_activate_dalitz_plot @ <>= procedure :: register_dalitz_plot => pcm_nlo_register_dalitz_plot <>= module subroutine pcm_nlo_register_dalitz_plot (pcm, emitter, p) class(pcm_nlo_t), intent(inout) :: pcm integer, intent(in) :: emitter type(vector4_t), intent(in), dimension(:) :: p end subroutine pcm_nlo_register_dalitz_plot <>= module subroutine pcm_nlo_register_dalitz_plot (pcm, emitter, p) class(pcm_nlo_t), intent(inout) :: pcm integer, intent(in) :: emitter type(vector4_t), intent(in), dimension(:) :: p real(default) :: k0_n, k0_np1 k0_n = p(emitter)%p(0) k0_np1 = p(size(p))%p(0) call pcm%dalitz_plot%register (k0_n, k0_np1) end subroutine pcm_nlo_register_dalitz_plot @ %def pcm_nlo_register_dalitz_plot @ <>= procedure :: setup_phs_generator => pcm_nlo_setup_phs_generator <>= module subroutine pcm_nlo_setup_phs_generator (pcm, pcm_work, generator, & sqrts, mode, singular_jacobian) class(pcm_nlo_t), intent(in) :: pcm type(phs_fks_generator_t), intent(inout) :: generator type(pcm_nlo_workspace_t), intent(in), target :: pcm_work real(default), intent(in) :: sqrts integer, intent(in), optional:: mode logical, intent(in), optional :: singular_jacobian end subroutine pcm_nlo_setup_phs_generator <>= module subroutine pcm_nlo_setup_phs_generator (pcm, pcm_work, generator, & sqrts, mode, singular_jacobian) class(pcm_nlo_t), intent(in) :: pcm type(phs_fks_generator_t), intent(inout) :: generator type(pcm_nlo_workspace_t), intent(in), target :: pcm_work real(default), intent(in) :: sqrts integer, intent(in), optional:: mode logical, intent(in), optional :: singular_jacobian logical :: yorn yorn = .false.; if (present (singular_jacobian)) yorn = singular_jacobian call generator%connect_kinematics (pcm_work%isr_kinematics, & pcm_work%real_kinematics, pcm%has_massive_emitter ()) generator%n_in = pcm%region_data%n_in call generator%set_sqrts_hat (sqrts) call generator%set_emitters (pcm%region_data%emitters) call generator%setup_masses (pcm%region_data%n_legs_born) generator%is_massive = pcm%get_mass_info (1) generator%singular_jacobian = yorn if (present (mode)) generator%mode = mode call generator%set_xi_and_y_bounds (pcm%settings%fks_template%xi_min, & pcm%settings%fks_template%y_max) end subroutine pcm_nlo_setup_phs_generator @ %def pcm_nlo_setup_phs_generator @ <>= procedure :: final => pcm_nlo_final <>= module subroutine pcm_nlo_final (pcm) class(pcm_nlo_t), intent(inout) :: pcm end subroutine pcm_nlo_final <>= module subroutine pcm_nlo_final (pcm) class(pcm_nlo_t), intent(inout) :: pcm if (allocated (pcm%real_partition)) deallocate (pcm%real_partition) call pcm%dalitz_plot%final () end subroutine pcm_nlo_final @ %def pcm_nlo_final @ <>= procedure :: is_nlo => pcm_nlo_is_nlo <>= module function pcm_nlo_is_nlo (pcm) result (is_nlo) logical :: is_nlo class(pcm_nlo_t), intent(in) :: pcm end function pcm_nlo_is_nlo <>= module function pcm_nlo_is_nlo (pcm) result (is_nlo) logical :: is_nlo class(pcm_nlo_t), intent(in) :: pcm is_nlo = .true. end function pcm_nlo_is_nlo @ %def pcm_nlo_is_nlo @ As a first implementation, it acts as a wrapper for the NLO controller object and the squared matrix-element collector. <>= public :: pcm_nlo_workspace_t <>= type, extends (pcm_workspace_t) :: pcm_nlo_workspace_t type(real_kinematics_t), pointer :: real_kinematics => null () type(isr_kinematics_t), pointer :: isr_kinematics => null () type(real_subtraction_t) :: real_sub type(virtual_t) :: virtual type(soft_mismatch_t) :: soft_mismatch type(dglap_remnant_t) :: dglap_remnant integer, dimension(:), allocatable :: i_mci_to_real_component contains <> end type pcm_nlo_workspace_t @ %def pcm_nlo_workspace_t @ <>= procedure :: set_radiation_event => pcm_nlo_workspace_set_radiation_event procedure :: set_subtraction_event => pcm_nlo_workspace_set_subtraction_event <>= module subroutine pcm_nlo_workspace_set_radiation_event (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work end subroutine pcm_nlo_workspace_set_radiation_event module subroutine pcm_nlo_workspace_set_subtraction_event (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work end subroutine pcm_nlo_workspace_set_subtraction_event <>= module subroutine pcm_nlo_workspace_set_radiation_event (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work pcm_work%real_sub%radiation_event = .true. pcm_work%real_sub%subtraction_event = .false. end subroutine pcm_nlo_workspace_set_radiation_event module subroutine pcm_nlo_workspace_set_subtraction_event (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work pcm_work%real_sub%radiation_event = .false. pcm_work%real_sub%subtraction_event = .true. end subroutine pcm_nlo_workspace_set_subtraction_event @ %def pcm_nlo_workspace_set_radiation_event @ %def pcm_nlo_workspace_set_subtraction_event <>= procedure :: disable_subtraction => pcm_nlo_workspace_disable_subtraction <>= module subroutine pcm_nlo_workspace_disable_subtraction (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work end subroutine pcm_nlo_workspace_disable_subtraction <>= module subroutine pcm_nlo_workspace_disable_subtraction (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work pcm_work%real_sub%subtraction_deactivated = .true. end subroutine pcm_nlo_workspace_disable_subtraction @ %def pcm_nlo_workspace_disable_subtraction @ <>= procedure :: init_config => pcm_nlo_workspace_init_config <>= module subroutine pcm_nlo_workspace_init_config (pcm_work, pcm, & active_components, nlo_types, energy, i_real_fin, model) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm logical, intent(in), dimension(:) :: active_components integer, intent(in), dimension(:) :: nlo_types real(default), intent(in), dimension(:) :: energy integer, intent(in) :: i_real_fin class(model_data_t), intent(in) :: model end subroutine pcm_nlo_workspace_init_config <>= module subroutine pcm_nlo_workspace_init_config (pcm_work, pcm, & active_components, nlo_types, energy, i_real_fin, model) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm logical, intent(in), dimension(:) :: active_components integer, intent(in), dimension(:) :: nlo_types real(default), intent(in), dimension(:) :: energy integer, intent(in) :: i_real_fin class(model_data_t), intent(in) :: model integer :: i_component if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, & "pcm_nlo_workspace_init_config") call pcm_work%init_real_and_isr_kinematics (pcm, energy) select type (pcm) type is (pcm_nlo_t) do i_component = 1, size (active_components) if (active_components(i_component) .or. & pcm%settings%combined_integration) then select case (nlo_types(i_component)) case (NLO_REAL) if (i_component /= i_real_fin) then call pcm_work%setup_real_component (pcm, & pcm%settings%fks_template%subtraction_disabled) end if case (NLO_VIRTUAL) call pcm_work%init_virtual (pcm, model) case (NLO_MISMATCH) call pcm_work%init_soft_mismatch (pcm) case (NLO_DGLAP) call pcm_work%init_dglap_remnant (pcm) end select end if end do end select end subroutine pcm_nlo_workspace_init_config @ %def pcm_nlo_workspace_init_config @ <>= procedure :: setup_real_component => pcm_nlo_workspace_setup_real_component <>= module subroutine pcm_nlo_workspace_setup_real_component (pcm_work, pcm, & subtraction_disabled) class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work class(pcm_t), intent(in) :: pcm logical, intent(in) :: subtraction_disabled end subroutine pcm_nlo_workspace_setup_real_component <>= module subroutine pcm_nlo_workspace_setup_real_component (pcm_work, pcm, & subtraction_disabled) class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work class(pcm_t), intent(in) :: pcm logical, intent(in) :: subtraction_disabled select type (pcm) type is (pcm_nlo_t) call pcm_work%init_real_subtraction (pcm) if (subtraction_disabled) call pcm_work%disable_subtraction () end select end subroutine pcm_nlo_workspace_setup_real_component @ %def pcm_nlo_workspace_setup_real_component @ <>= procedure :: init_real_and_isr_kinematics => & pcm_nlo_workspace_init_real_and_isr_kinematics <>= module subroutine pcm_nlo_workspace_init_real_and_isr_kinematics & (pcm_work, pcm, energy) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm real(default), dimension(:), intent(in) :: energy end subroutine pcm_nlo_workspace_init_real_and_isr_kinematics <>= module subroutine pcm_nlo_workspace_init_real_and_isr_kinematics & (pcm_work, pcm, energy) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm real(default), dimension(:), intent(in) :: energy integer :: n_contr allocate (pcm_work%real_kinematics) allocate (pcm_work%isr_kinematics) select type (pcm) type is (pcm_nlo_t) associate (region_data => pcm%region_data) if (allocated (region_data%alr_contributors)) then n_contr = size (region_data%alr_contributors) else if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) then n_contr = 2 else n_contr = 1 end if call pcm_work%real_kinematics%init & (region_data%n_legs_real, region_data%n_phs, & region_data%n_regions, n_contr) if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) & call pcm_work%real_kinematics%init_onshell & (region_data%n_legs_real, region_data%n_phs) pcm_work%isr_kinematics%n_in = region_data%n_in end associate end select pcm_work%isr_kinematics%beam_energy = energy end subroutine pcm_nlo_workspace_init_real_and_isr_kinematics @ %def pcm_nlo_workspace_init_real_and_isr_kinematics @ <>= procedure :: set_real_and_isr_kinematics => & pcm_nlo_workspace_set_real_and_isr_kinematics <>= module subroutine pcm_nlo_workspace_set_real_and_isr_kinematics & (pcm_work, phs_identifiers, sqrts) class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers real(default), intent(in) :: sqrts end subroutine pcm_nlo_workspace_set_real_and_isr_kinematics <>= module subroutine pcm_nlo_workspace_set_real_and_isr_kinematics & (pcm_work, phs_identifiers, sqrts) class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers real(default), intent(in) :: sqrts call pcm_work%real_sub%set_real_kinematics & (pcm_work%real_kinematics) call pcm_work%real_sub%set_isr_kinematics & (pcm_work%isr_kinematics) end subroutine pcm_nlo_workspace_set_real_and_isr_kinematics @ %def pcm_nlo_workspace_set_real_and_isr_kinematics @ <>= procedure :: init_real_subtraction => pcm_nlo_workspace_init_real_subtraction <>= module subroutine pcm_nlo_workspace_init_real_subtraction (pcm_work, pcm) class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work class(pcm_t), intent(in) :: pcm end subroutine pcm_nlo_workspace_init_real_subtraction <>= module subroutine pcm_nlo_workspace_init_real_subtraction (pcm_work, pcm) class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work class(pcm_t), intent(in) :: pcm select type (pcm) type is (pcm_nlo_t) associate (region_data => pcm%region_data) call pcm_work%real_sub%init (region_data, pcm%settings) if (allocated (pcm%settings%selected_alr)) then associate (selected_alr => pcm%settings%selected_alr) if (any (selected_alr < 0)) then call msg_fatal ("Fixed alpha region must be non-negative!") else if (any (selected_alr > region_data%n_regions)) then call msg_fatal ("Fixed alpha region is larger than the"& &" total number of singular regions!") else allocate (pcm_work%real_sub%selected_alr & (size (selected_alr))) pcm_work%real_sub%selected_alr = selected_alr end if end associate end if end associate end select end subroutine pcm_nlo_workspace_init_real_subtraction @ %def pcm_nlo_workspace_init_real_subtraction @ <>= procedure :: set_momenta_and_scales_virtual => & pcm_nlo_workspace_set_momenta_and_scales_virtual <>= module subroutine pcm_nlo_workspace_set_momenta_and_scales_virtual & (pcm_work, p, ren_scale, fac_scale, es_scale) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work type(vector4_t), intent(in), dimension(:) :: p real(default), allocatable, intent(in) :: ren_scale real(default), intent(in) :: fac_scale real(default), allocatable, intent(in) :: es_scale end subroutine pcm_nlo_workspace_set_momenta_and_scales_virtual <>= module subroutine pcm_nlo_workspace_set_momenta_and_scales_virtual & (pcm_work, p, ren_scale, fac_scale, es_scale) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work type(vector4_t), intent(in), dimension(:) :: p real(default), allocatable, intent(in) :: ren_scale real(default), intent(in) :: fac_scale real(default), allocatable, intent(in) :: es_scale associate (virtual => pcm_work%virtual) call virtual%set_ren_scale (ren_scale) call virtual%set_fac_scale (p, fac_scale) call virtual%set_ellis_sexton_scale (es_scale) end associate end subroutine pcm_nlo_workspace_set_momenta_and_scales_virtual @ %def pcm_nlo_workspace_set_momenta_and_scales_virtual @ <>= procedure :: set_fac_scale => pcm_nlo_workspace_set_fac_scale <>= module subroutine pcm_nlo_workspace_set_fac_scale (pcm_work, fac_scale) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work real(default), intent(in) :: fac_scale end subroutine pcm_nlo_workspace_set_fac_scale <>= module subroutine pcm_nlo_workspace_set_fac_scale (pcm_work, fac_scale) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work real(default), intent(in) :: fac_scale pcm_work%isr_kinematics%fac_scale = fac_scale end subroutine pcm_nlo_workspace_set_fac_scale @ %def pcm_nlo_workspace_set_fac_scale @ <>= procedure :: set_momenta => pcm_nlo_workspace_set_momenta <>= module subroutine pcm_nlo_workspace_set_momenta (pcm_work, & p_born, p_real, i_phs, cms) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work type(vector4_t), dimension(:), intent(in) :: p_born, p_real integer, intent(in) :: i_phs logical, intent(in), optional :: cms end subroutine pcm_nlo_workspace_set_momenta <>= module subroutine pcm_nlo_workspace_set_momenta (pcm_work, & p_born, p_real, i_phs, cms) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work type(vector4_t), dimension(:), intent(in) :: p_born, p_real integer, intent(in) :: i_phs logical, intent(in), optional :: cms logical :: yorn yorn = .false.; if (present (cms)) yorn = cms associate (kinematics => pcm_work%real_kinematics) if (yorn) then if (.not. kinematics%p_born_cms%initialized) & call kinematics%p_born_cms%init (size (p_born), 1) if (.not. kinematics%p_real_cms%initialized) & call kinematics%p_real_cms%init (size (p_real), 1) kinematics%p_born_cms%phs_point(1) = p_born kinematics%p_real_cms%phs_point(i_phs) = p_real else if (.not. kinematics%p_born_lab%initialized) & call kinematics%p_born_lab%init (size (p_born), 1) if (.not. kinematics%p_real_lab%initialized) & call kinematics%p_real_lab%init (size (p_real), 1) kinematics%p_born_lab%phs_point(1) = p_born kinematics%p_real_lab%phs_point(i_phs) = p_real end if end associate end subroutine pcm_nlo_workspace_set_momenta @ %def pcm_nlo_workspace_set_momenta @ <>= procedure :: get_momenta => pcm_nlo_workspace_get_momenta <>= module function pcm_nlo_workspace_get_momenta (pcm_work, pcm, & i_phs, born_phsp, cms) result (p) type(vector4_t), dimension(:), allocatable :: p class(pcm_nlo_workspace_t), intent(in) :: pcm_work class(pcm_t), intent(in) :: pcm integer, intent(in) :: i_phs logical, intent(in) :: born_phsp logical, intent(in), optional :: cms end function pcm_nlo_workspace_get_momenta <>= module function pcm_nlo_workspace_get_momenta (pcm_work, pcm, & i_phs, born_phsp, cms) result (p) type(vector4_t), dimension(:), allocatable :: p class(pcm_nlo_workspace_t), intent(in) :: pcm_work class(pcm_t), intent(in) :: pcm integer, intent(in) :: i_phs logical, intent(in) :: born_phsp logical, intent(in), optional :: cms logical :: yorn yorn = .false.; if (present (cms)) yorn = cms select type (pcm) type is (pcm_nlo_t) if (born_phsp) then if (yorn) then p = pcm_work%real_kinematics%p_born_cms%phs_point(1) else p = pcm_work%real_kinematics%p_born_lab%phs_point(1) end if else if (yorn) then p = pcm_work%real_kinematics%p_real_cms%phs_point(i_phs) else p = pcm_work%real_kinematics%p_real_lab%phs_point(i_phs) end if end if end select end function pcm_nlo_workspace_get_momenta @ %def pcm_nlo_workspace_get_momenta @ <>= procedure :: get_xi_max => pcm_nlo_workspace_get_xi_max <>= module function pcm_nlo_workspace_get_xi_max (pcm_work, alr) result (xi_max) real(default) :: xi_max class(pcm_nlo_workspace_t), intent(in) :: pcm_work integer, intent(in) :: alr end function pcm_nlo_workspace_get_xi_max <>= module function pcm_nlo_workspace_get_xi_max (pcm_work, alr) result (xi_max) real(default) :: xi_max class(pcm_nlo_workspace_t), intent(in) :: pcm_work integer, intent(in) :: alr integer :: i_phs i_phs = pcm_work%real_kinematics%alr_to_i_phs (alr) xi_max = pcm_work%real_kinematics%xi_max (i_phs) end function pcm_nlo_workspace_get_xi_max @ %def pcm_nlo_workspace_get_xi_max @ <>= procedure :: set_x_rad => pcm_nlo_workspace_set_x_rad <>= module subroutine pcm_nlo_workspace_set_x_rad (pcm_work, x_tot) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work real(default), intent(in), dimension(:) :: x_tot end subroutine pcm_nlo_workspace_set_x_rad <>= module subroutine pcm_nlo_workspace_set_x_rad (pcm_work, x_tot) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work real(default), intent(in), dimension(:) :: x_tot integer :: n_par n_par = size (x_tot) if (n_par < 3) then pcm_work%real_kinematics%x_rad = zero else pcm_work%real_kinematics%x_rad = x_tot (n_par - 2 : n_par) end if end subroutine pcm_nlo_workspace_set_x_rad @ %def pcm_nlo_workspace_set_x_rad @ <>= procedure :: init_virtual => pcm_nlo_workspace_init_virtual <>= module subroutine pcm_nlo_workspace_init_virtual (pcm_work, pcm, model) class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work class(pcm_t), intent(in) :: pcm class(model_data_t), intent(in) :: model end subroutine pcm_nlo_workspace_init_virtual <>= module subroutine pcm_nlo_workspace_init_virtual (pcm_work, pcm, model) class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work class(pcm_t), intent(in) :: pcm class(model_data_t), intent(in) :: model select type (pcm) type is (pcm_nlo_t) associate (region_data => pcm%region_data) call pcm_work%virtual%init (region_data%get_flv_states_born (), & region_data%n_in, pcm%settings, model, pcm%has_pdfs) end associate end select end subroutine pcm_nlo_workspace_init_virtual @ %def pcm_nlo_workspace_init_virtual @ <>= procedure :: disable_virtual_subtraction => & pcm_nlo_workspace_disable_virtual_subtraction <>= module subroutine pcm_nlo_workspace_disable_virtual_subtraction (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work end subroutine pcm_nlo_workspace_disable_virtual_subtraction <>= module subroutine pcm_nlo_workspace_disable_virtual_subtraction (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work end subroutine pcm_nlo_workspace_disable_virtual_subtraction @ %def pcm_nlo_workspace_disable_virtual_subtraction @ <>= procedure :: compute_sqme_virt => pcm_nlo_workspace_compute_sqme_virt <>= module subroutine pcm_nlo_workspace_compute_sqme_virt (pcm_work, pcm, p, & alpha_coupling, separate_uborns, sqme_virt) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm type(vector4_t), intent(in), dimension(:) :: p real(default), dimension(2), intent(in) :: alpha_coupling logical, intent(in) :: separate_uborns real(default), dimension(:), allocatable, intent(inout) :: sqme_virt end subroutine pcm_nlo_workspace_compute_sqme_virt <>= module subroutine pcm_nlo_workspace_compute_sqme_virt (pcm_work, pcm, p, & alpha_coupling, separate_uborns, sqme_virt) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm type(vector4_t), intent(in), dimension(:) :: p real(default), dimension(2), intent(in) :: alpha_coupling logical, intent(in) :: separate_uborns real(default), dimension(:), allocatable, intent(inout) :: sqme_virt type(vector4_t), dimension(:), allocatable :: pp associate (virtual => pcm_work%virtual) allocate (pp (size (p))) if (virtual%settings%factorization_mode == FACTORIZATION_THRESHOLD) then pp = pcm_work%real_kinematics%p_born_onshell%get_momenta (1) else pp = p end if select type (pcm) type is (pcm_nlo_t) if (separate_uborns) then allocate (sqme_virt (pcm%get_n_flv_born ())) else allocate (sqme_virt (1)) end if sqme_virt = zero call virtual%evaluate (pcm%region_data, & alpha_coupling, pp, separate_uborns, sqme_virt) end select end associate end subroutine pcm_nlo_workspace_compute_sqme_virt @ %def pcm_nlo_workspace_compute_sqme_virt @ <>= procedure :: compute_sqme_mismatch => pcm_nlo_workspace_compute_sqme_mismatch <>= module subroutine pcm_nlo_workspace_compute_sqme_mismatch (pcm_work, pcm, & alpha_s, separate_uborns, sqme_mism) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm real(default), intent(in) :: alpha_s logical, intent(in) :: separate_uborns real(default), dimension(:), allocatable, intent(inout) :: sqme_mism end subroutine pcm_nlo_workspace_compute_sqme_mismatch <>= module subroutine pcm_nlo_workspace_compute_sqme_mismatch (pcm_work, pcm, & alpha_s, separate_uborns, sqme_mism) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm real(default), intent(in) :: alpha_s logical, intent(in) :: separate_uborns real(default), dimension(:), allocatable, intent(inout) :: sqme_mism select type (pcm) type is (pcm_nlo_t) if (separate_uborns) then allocate (sqme_mism (pcm%get_n_flv_born ())) else allocate (sqme_mism (1)) end if sqme_mism = zero sqme_mism = pcm_work%soft_mismatch%evaluate (alpha_s) end select end subroutine pcm_nlo_workspace_compute_sqme_mismatch @ %def pcm_nlo_workspace_compute_sqme_mismatch @ <>= procedure :: compute_sqme_dglap_remnant => & pcm_nlo_workspace_compute_sqme_dglap_remnant <>= module subroutine pcm_nlo_workspace_compute_sqme_dglap_remnant (pcm_work, & pcm, alpha_coupling, separate_uborns, sqme_dglap) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm real(default), dimension(2), intent(in) :: alpha_coupling logical, intent(in) :: separate_uborns real(default), dimension(:), allocatable, intent(inout) :: sqme_dglap end subroutine pcm_nlo_workspace_compute_sqme_dglap_remnant <>= module subroutine pcm_nlo_workspace_compute_sqme_dglap_remnant (pcm_work, & pcm, alpha_coupling, separate_uborns, sqme_dglap) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm real(default), dimension(2), intent(in) :: alpha_coupling logical, intent(in) :: separate_uborns real(default), dimension(:), allocatable, intent(inout) :: sqme_dglap select type (pcm) type is (pcm_nlo_t) if (separate_uborns) then allocate (sqme_dglap (pcm%get_n_flv_born ())) else allocate (sqme_dglap (1)) end if end select sqme_dglap = zero call pcm_work%dglap_remnant%evaluate (alpha_coupling, & separate_uborns, sqme_dglap) end subroutine pcm_nlo_workspace_compute_sqme_dglap_remnant @ %def pcm_nlo_workspace_compute_sqme_dglap_remnant @ <>= procedure :: set_fixed_order_event_mode => & pcm_nlo_workspace_set_fixed_order_event_mode <>= module subroutine pcm_nlo_workspace_set_fixed_order_event_mode (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work end subroutine pcm_nlo_workspace_set_fixed_order_event_mode <>= module subroutine pcm_nlo_workspace_set_fixed_order_event_mode (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work pcm_work%real_sub%purpose = FIXED_ORDER_EVENTS end subroutine pcm_nlo_workspace_set_fixed_order_event_mode @ %def pcm_nlo_workspace_set_fixed_order_event_mode @ <>= procedure :: init_soft_mismatch => pcm_nlo_workspace_init_soft_mismatch <>= module subroutine pcm_nlo_workspace_init_soft_mismatch (pcm_work, pcm) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm end subroutine pcm_nlo_workspace_init_soft_mismatch <>= module subroutine pcm_nlo_workspace_init_soft_mismatch (pcm_work, pcm) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm select type (pcm) type is (pcm_nlo_t) call pcm_work%soft_mismatch%init (pcm%region_data, & pcm_work%real_kinematics, pcm%settings%factorization_mode) end select end subroutine pcm_nlo_workspace_init_soft_mismatch @ %def pcm_nlo_workspace_init_soft_mismatch @ <>= procedure :: init_dglap_remnant => pcm_nlo_workspace_init_dglap_remnant <>= module subroutine pcm_nlo_workspace_init_dglap_remnant (pcm_work, pcm) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm end subroutine pcm_nlo_workspace_init_dglap_remnant <>= module subroutine pcm_nlo_workspace_init_dglap_remnant (pcm_work, pcm) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm select type (pcm) type is (pcm_nlo_t) call pcm_work%dglap_remnant%init ( & pcm%settings, & pcm%region_data, & pcm_work%isr_kinematics) end select end subroutine pcm_nlo_workspace_init_dglap_remnant @ %def pcm_nlo_workspace_init_dglap_remnant @ <>= procedure :: is_fixed_order_nlo_events & => pcm_nlo_workspace_is_fixed_order_nlo_events <>= module function pcm_nlo_workspace_is_fixed_order_nlo_events & (pcm_work) result (is_fnlo) logical :: is_fnlo class(pcm_nlo_workspace_t), intent(in) :: pcm_work end function pcm_nlo_workspace_is_fixed_order_nlo_events <>= module function pcm_nlo_workspace_is_fixed_order_nlo_events & (pcm_work) result (is_fnlo) logical :: is_fnlo class(pcm_nlo_workspace_t), intent(in) :: pcm_work is_fnlo = pcm_work%real_sub%purpose == FIXED_ORDER_EVENTS end function pcm_nlo_workspace_is_fixed_order_nlo_events @ %def pcm_nlo_workspace_is_fixed_order_nlo_events @ <>= procedure :: final => pcm_nlo_workspace_final <>= module subroutine pcm_nlo_workspace_final (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work end subroutine pcm_nlo_workspace_final <>= module subroutine pcm_nlo_workspace_final (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work call pcm_work%real_sub%final () call pcm_work%virtual%final () call pcm_work%soft_mismatch%final () call pcm_work%dglap_remnant%final () if (associated (pcm_work%real_kinematics)) then call pcm_work%real_kinematics%final () nullify (pcm_work%real_kinematics) end if if (associated (pcm_work%isr_kinematics)) then nullify (pcm_work%isr_kinematics) end if end subroutine pcm_nlo_workspace_final @ %def pcm_nlo_workspace_final @ <>= procedure :: is_nlo => pcm_nlo_workspace_is_nlo <>= module function pcm_nlo_workspace_is_nlo (pcm_work) result (is_nlo) logical :: is_nlo class(pcm_nlo_workspace_t), intent(inout) :: pcm_work end function pcm_nlo_workspace_is_nlo <>= module function pcm_nlo_workspace_is_nlo (pcm_work) result (is_nlo) logical :: is_nlo class(pcm_nlo_workspace_t), intent(inout) :: pcm_work is_nlo = .true. end function pcm_nlo_workspace_is_nlo @ %def pcm_nlo_workspace_is_nlo @ This routine modifies the kinematic factors applied to the real matrix element for use with POWHEG matching. We need to divide the real matrix element by [[xi_max]] to cancel a factor of [[xi_max]] applied in [[apply_kinematic_factors_radiation]]. It comes from the fact that we sample $\tilde\xi \in [0,1]$ when integrating but $\xi \in [p_T^2,\xi_\text{max}]$ for POWHEG matching. Thus, we are taking into account that $d\xi = d\tilde\xi \frac{\xi}{\tilde\xi} = d\tilde\xi \xi_\text{max}$. Additionally, we need to cancel the Jacobian from the random number mapping. We only want the physical part of the Jacobian in our Sudakov splitting function. Furthermore, the real matrix element lacks its flux factor $\frac{1}{2 \hat s_{\mathcal{R}}}$ and the real Jacobian lacks a factor of $\frac{1}{1-\xi}$. Together, this is a factor of $\frac{1}{2 \hat s_{\mathcal{B}}}$, i.e. the same as the flux factor of the Born matrix element. We do not correct any of both here, as only the ratio of both will be relevant for the Sudakov. <>= procedure :: powheg_kinematic_factors_real => & pcm_nlo_workspace_powheg_kinematic_factors_real <>= module function pcm_nlo_workspace_powheg_kinematic_factors_real & (pcm_work, sqme_real, alr) result (sqme_real_corr) real(default) :: sqme_real_corr class(pcm_nlo_workspace_t), intent(in) :: pcm_work real(default), intent(in) :: sqme_real integer, intent(in) :: alr end function pcm_nlo_workspace_powheg_kinematic_factors_real <>= module function pcm_nlo_workspace_powheg_kinematic_factors_real & (pcm_work, sqme_real, alr) result (sqme_real_corr) real(default) :: sqme_real_corr class(pcm_nlo_workspace_t), intent(in) :: pcm_work real(default), intent(in) :: sqme_real integer, intent(in) :: alr real(default) :: xi_max, jac_rand integer :: i_phs xi_max = pcm_work%get_xi_max (alr) i_phs = pcm_work%real_kinematics%alr_to_i_phs (alr) jac_rand = pcm_work%real_kinematics%jac_rand (i_phs) sqme_real_corr = sqme_real / xi_max / jac_rand end function pcm_nlo_workspace_powheg_kinematic_factors_real @ %def pcm_nlo_workspace_powheg_kinematic_factors_real @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Kinematics instance} In this data type we combine all objects (instances) necessary for generating (or recovering) a kinematical configuration. The components work together as an implementation of multi-channel phase space. [[sf_chain]] is an instance of the structure-function chain. It is used both for generating kinematics and, after the proper scale has been determined, evaluating the structure function entries. [[phs]] is an instance of the phase space for the elementary process. The array [[f]] contains the products of the Jacobians that originate from parameter mappings in the structure-function chain or in the phase space. We allocate this explicitly if either [[sf_chain]] or [[phs]] are explicitly allocated, otherwise we can take over a pointer. All components are implemented as pointers to (anonymous) targets. For each component, there is a flag that tells whether this component is to be regarded as a proper component (`owned' by the object) or as a pointer. @ <<[[kinematics.f90]]>>= <> module kinematics <> use lorentz use physics_defs use sf_base use phs_base use fks_regions use mci_base use process_config use process_mci use pcm_base, only: pcm_t, pcm_workspace_t use pcm, only: pcm_nlo_t, pcm_nlo_workspace_t <> <> <> interface <> end interface end module kinematics @ %def kinematics @ <<[[kinematics_sub.f90]]>>= <> submodule (kinematics) kinematics_s <> use format_utils, only: write_separator use diagnostics use io_units use phs_points, only: assignment(=), size use interactions use phs_fks use ttv_formfactors, only: m1s_to_mpole implicit none contains <> end submodule kinematics_s @ %def kinematics_s @ <>= public :: kinematics_t <>= type :: kinematics_t integer :: n_in = 0 integer :: n_channel = 0 integer :: selected_channel = 0 type(sf_chain_instance_t), pointer :: sf_chain => null () class(phs_t), pointer :: phs => null () real(default), dimension(:), pointer :: f => null () real(default) :: phs_factor logical :: sf_chain_allocated = .false. logical :: phs_allocated = .false. logical :: f_allocated = .false. integer :: emitter = -1 integer :: i_phs = 0 integer :: i_con = 0 logical :: only_cm_frame = .false. logical :: new_seed = .true. logical :: threshold = .false. contains <> end type kinematics_t @ %def kinematics_t @ Output. Show only those components which are marked as owned. <>= procedure :: write => kinematics_write <>= module subroutine kinematics_write (object, unit) class(kinematics_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine kinematics_write <>= module subroutine kinematics_write (object, unit) class(kinematics_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, c u = given_output_unit (unit) if (object%f_allocated) then write (u, "(1x,A)") "Flux * PHS volume:" write (u, "(2x,ES19.12)") object%phs_factor write (u, "(1x,A)") "Jacobian factors per channel:" do c = 1, size (object%f) write (u, "(3x,I0,':',1x,ES14.7)", advance="no") c, object%f(c) if (c == object%selected_channel) then write (u, "(1x,A)") "[selected]" else write (u, *) end if end do end if if (object%sf_chain_allocated) then call write_separator (u) call object%sf_chain%write (u) end if if (object%phs_allocated) then call write_separator (u) call object%phs%write (u) end if end subroutine kinematics_write @ %def kinematics_write @ Finalizer. Delete only those components which are marked as owned. <>= procedure :: final => kinematics_final <>= module subroutine kinematics_final (object) class(kinematics_t), intent(inout) :: object end subroutine kinematics_final <>= module subroutine kinematics_final (object) class(kinematics_t), intent(inout) :: object if (object%sf_chain_allocated) then call object%sf_chain%final () deallocate (object%sf_chain) object%sf_chain_allocated = .false. end if if (object%phs_allocated) then call object%phs%final () deallocate (object%phs) object%phs_allocated = .false. end if if (object%f_allocated) then deallocate (object%f) object%f_allocated = .false. end if end subroutine kinematics_final @ %def kinematics_final @ Configure the kinematics object. This consists of several configuration steps which correspond to individual procedures. In essence, we configure the structure-function part, the partonic phase-space part, and various NLO items. TODO wk 19-03-01: This includes some region-data setup within [[pcm]], hence [[pcm]] is intent(inout). This should be moved elsewhere, so [[pcm]] can become strictly intent(in). <>= procedure :: configure => kinematics_configure <>= module subroutine kinematics_configure (kin, pcm, pcm_work, & sf_chain, beam_config, phs_config, nlo_type, is_i_sub) class(kinematics_t), intent(out) :: kin class(pcm_t), intent(inout) :: pcm class(pcm_workspace_t), intent(in) :: pcm_work type(sf_chain_t), intent(in), target :: sf_chain type(process_beam_config_t), intent(in), target :: beam_config class(phs_config_t), intent(in), target :: phs_config integer, intent(in) :: nlo_type logical, intent(in) :: is_i_sub end subroutine kinematics_configure <>= module subroutine kinematics_configure (kin, pcm, pcm_work, & sf_chain, beam_config, phs_config, nlo_type, is_i_sub) class(kinematics_t), intent(out) :: kin class(pcm_t), intent(inout) :: pcm class(pcm_workspace_t), intent(in) :: pcm_work type(sf_chain_t), intent(in), target :: sf_chain type(process_beam_config_t), intent(in), target :: beam_config class(phs_config_t), intent(in), target :: phs_config integer, intent(in) :: nlo_type logical, intent(in) :: is_i_sub logical :: extended_sf extended_sf = nlo_type == NLO_DGLAP .or. & (nlo_type == NLO_REAL .and. is_i_sub) call kin%init_sf_chain (sf_chain, beam_config, & extended_sf = pcm%has_pdfs .and. extended_sf) !!! Add one for additional Born matrix element call kin%init_phs (phs_config) call kin%set_nlo_info (nlo_type) select type (phs => kin%phs) type is (phs_fks_t) call phs%allocate_momenta (phs_config, .not. (nlo_type == NLO_REAL)) select type (pcm) type is (pcm_nlo_t) call pcm%region_data%init_phs_identifiers (phs%phs_identifiers) !!! The triple select type pyramid of doom select type (pcm_work) type is (pcm_nlo_workspace_t) if (allocated (pcm_work%real_kinematics%alr_to_i_phs)) & call pcm%region_data%set_alr_to_i_phs (phs%phs_identifiers, & pcm_work%real_kinematics%alr_to_i_phs) end select end select end select end subroutine kinematics_configure @ %def kinematics_configure @ Set the flags indicating whether the phase space shall be set up for the calculation of the real contribution. For this case, also set the emitter. <>= procedure :: set_nlo_info => kinematics_set_nlo_info <>= module subroutine kinematics_set_nlo_info (k, nlo_type) class(kinematics_t), intent(inout) :: k integer, intent(in) :: nlo_type end subroutine kinematics_set_nlo_info <>= module subroutine kinematics_set_nlo_info (k, nlo_type) class(kinematics_t), intent(inout) :: k integer, intent(in) :: nlo_type if (nlo_type == NLO_VIRTUAL) k%only_cm_frame = .true. end subroutine kinematics_set_nlo_info @ %def kinematics_set_nlo_info @ <>= procedure :: set_threshold => kinematics_set_threshold <>= module subroutine kinematics_set_threshold (kin, factorization_mode) class(kinematics_t), intent(inout) :: kin integer, intent(in) :: factorization_mode end subroutine kinematics_set_threshold <>= module subroutine kinematics_set_threshold (kin, factorization_mode) class(kinematics_t), intent(inout) :: kin integer, intent(in) :: factorization_mode kin%threshold = factorization_mode == FACTORIZATION_THRESHOLD end subroutine kinematics_set_threshold @ %def kinematics_set_threshold @ Allocate the structure-function chain instance, initialize it as a copy of the [[sf_chain]] template, and prepare it for evaluation. The [[sf_chain]] remains a target because the (usually constant) beam momenta are taken from there. <>= procedure :: init_sf_chain => kinematics_init_sf_chain <>= module subroutine kinematics_init_sf_chain & (k, sf_chain, config, extended_sf) class(kinematics_t), intent(inout) :: k type(sf_chain_t), intent(in), target :: sf_chain type(process_beam_config_t), intent(in) :: config logical, intent(in), optional :: extended_sf end subroutine kinematics_init_sf_chain <>= module subroutine kinematics_init_sf_chain (k, sf_chain, config, extended_sf) class(kinematics_t), intent(inout) :: k type(sf_chain_t), intent(in), target :: sf_chain type(process_beam_config_t), intent(in) :: config logical, intent(in), optional :: extended_sf integer :: n_strfun, n_channel integer :: c k%n_in = config%data%get_n_in () n_strfun = config%n_strfun n_channel = config%n_channel allocate (k%sf_chain) k%sf_chain_allocated = .true. call k%sf_chain%init (sf_chain, n_channel) if (n_strfun /= 0) then do c = 1, n_channel call k%sf_chain%set_channel (c, config%sf_channel(c)) end do end if call k%sf_chain%link_interactions () call k%sf_chain%exchange_mask () call k%sf_chain%init_evaluators (extended_sf = extended_sf) end subroutine kinematics_init_sf_chain @ %def kinematics_init_sf_chain @ Allocate and initialize the phase-space part and the array of Jacobian factors. <>= procedure :: init_phs => kinematics_init_phs <>= module subroutine kinematics_init_phs (k, config) class(kinematics_t), intent(inout) :: k class(phs_config_t), intent(in), target :: config end subroutine kinematics_init_phs <>= module subroutine kinematics_init_phs (k, config) class(kinematics_t), intent(inout) :: k class(phs_config_t), intent(in), target :: config k%n_channel = config%get_n_channel () call config%allocate_instance (k%phs) call k%phs%init (config) k%phs_allocated = .true. allocate (k%f (k%n_channel)) k%f = 0 k%f_allocated = .true. end subroutine kinematics_init_phs @ %def kinematics_init_phs @ <>= procedure :: evaluate_radiation_kinematics => & kinematics_evaluate_radiation_kinematics <>= module subroutine kinematics_evaluate_radiation_kinematics (k, r_in) class(kinematics_t), intent(inout) :: k real(default), intent(in), dimension(:) :: r_in end subroutine kinematics_evaluate_radiation_kinematics <>= module subroutine kinematics_evaluate_radiation_kinematics (k, r_in) class(kinematics_t), intent(inout) :: k real(default), intent(in), dimension(:) :: r_in select type (phs => k%phs) type is (phs_fks_t) if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) then call phs%generate_radiation_variables & (r_in(phs%n_r_born + 1 : phs%n_r_born + 3), & threshold = k%threshold) call phs%compute_cms_energy () end if end select end subroutine kinematics_evaluate_radiation_kinematics @ %def kinematics_evaluate_radiation_kinematics @ <>= procedure :: generate_fsr_in => kinematics_generate_fsr_in <>= module subroutine kinematics_generate_fsr_in (kin) class(kinematics_t), intent(inout) :: kin end subroutine kinematics_generate_fsr_in <>= module subroutine kinematics_generate_fsr_in (kin) class(kinematics_t), intent(inout) :: kin select type (phs => kin%phs) type is (phs_fks_t) call phs%generate_fsr_in () end select end subroutine kinematics_generate_fsr_in @ %def kinematics_generate_fsr_in @ <>= procedure :: compute_xi_ref_momenta => kinematics_compute_xi_ref_momenta <>= module subroutine kinematics_compute_xi_ref_momenta (k, reg_data, nlo_type) class(kinematics_t), intent(inout) :: k type(region_data_t), intent(in) :: reg_data integer, intent(in) :: nlo_type end subroutine kinematics_compute_xi_ref_momenta <>= module subroutine kinematics_compute_xi_ref_momenta (k, reg_data, nlo_type) class(kinematics_t), intent(inout) :: k type(region_data_t), intent(in) :: reg_data integer, intent(in) :: nlo_type logical :: use_contributors use_contributors = allocated (reg_data%alr_contributors) select type (phs => k%phs) type is (phs_fks_t) if (use_contributors) then call phs%compute_xi_ref_momenta (contributors = reg_data%alr_contributors) else if (k%threshold) then if (.not. is_subtraction_component (k%emitter, nlo_type)) & call phs%compute_xi_ref_momenta_threshold () else call phs%compute_xi_ref_momenta () end if end select end subroutine kinematics_compute_xi_ref_momenta @ %def kinematics_compute_xi_ref_momenta @ Generate kinematics, given a phase-space channel and a MC parameter set. The main result is the momentum array [[p]], but we also fill the momentum entries in the structure-function chain and the Jacobian-factor array [[f]]. Regarding phase space, we fill only the parameter arrays for the selected channel. <>= procedure :: compute_selected_channel => kinematics_compute_selected_channel <>= module subroutine kinematics_compute_selected_channel & (k, mci_work, phs_channel, p, success) class(kinematics_t), intent(inout) :: k type(mci_work_t), intent(in) :: mci_work integer, intent(in) :: phs_channel type(vector4_t), dimension(:), intent(out) :: p logical, intent(out) :: success end subroutine kinematics_compute_selected_channel <>= module subroutine kinematics_compute_selected_channel & (k, mci_work, phs_channel, p, success) class(kinematics_t), intent(inout) :: k type(mci_work_t), intent(in) :: mci_work integer, intent(in) :: phs_channel type(vector4_t), dimension(:), intent(out) :: p logical, intent(out) :: success integer :: sf_channel k%selected_channel = phs_channel sf_channel = k%phs%config%get_sf_channel (phs_channel) call k%sf_chain%compute_kinematics (sf_channel, mci_work%get_x_strfun ()) call k%sf_chain%get_out_momenta (p(1:k%n_in)) call k%phs%set_incoming_momenta (p(1:k%n_in)) call k%phs%compute_flux () call k%phs%select_channel (phs_channel) call k%phs%evaluate_selected_channel (phs_channel, & mci_work%get_x_process ()) select type (phs => k%phs) type is (phs_fks_t) if (debug_on) call msg_debug2 (D_REAL, "phase space is phs_FKS") if (phs%q_defined) then call phs%get_born_momenta (p) if (debug_on) then call msg_debug2 (D_REAL, "q is defined") call msg_debug2 (D_REAL, "get_born_momenta called") end if k%phs_factor = phs%get_overall_factor () success = .true. else k%phs_factor = 0 success = .false. end if class default if (phs%q_defined) then call k%phs%get_outgoing_momenta (p(k%n_in + 1 :)) k%phs_factor = k%phs%get_overall_factor () success = .true. else k%phs_factor = 0 success = .false. end if end select end subroutine kinematics_compute_selected_channel @ %def kinematics_compute_selected_channel @ <>= procedure :: redo_sf_chain => kinematics_redo_sf_chain <>= module subroutine kinematics_redo_sf_chain (kin, mci_work, phs_channel) class(kinematics_t), intent(inout) :: kin type(mci_work_t), intent(in) :: mci_work integer, intent(in) :: phs_channel end subroutine kinematics_redo_sf_chain <>= module subroutine kinematics_redo_sf_chain (kin, mci_work, phs_channel) class(kinematics_t), intent(inout) :: kin type(mci_work_t), intent(in) :: mci_work integer, intent(in) :: phs_channel real(default), dimension(:), allocatable :: x integer :: sf_channel, n real(default) :: xi, y n = size (mci_work%get_x_strfun ()) if (n > 0) then allocate (x(n)) x = mci_work%get_x_strfun () sf_channel = kin%phs%config%get_sf_channel (phs_channel) call kin%sf_chain%compute_kinematics (sf_channel, x) end if end subroutine kinematics_redo_sf_chain @ %def kinematics_redo_sf_chain @ Complete kinematics by filling the non-selected phase-space parameter arrays. <>= procedure :: compute_other_channels => kinematics_compute_other_channels <>= module subroutine kinematics_compute_other_channels & (k, mci_work, phs_channel) class(kinematics_t), intent(inout) :: k type(mci_work_t), intent(in) :: mci_work integer, intent(in) :: phs_channel end subroutine kinematics_compute_other_channels <>= module subroutine kinematics_compute_other_channels (k, mci_work, phs_channel) class(kinematics_t), intent(inout) :: k type(mci_work_t), intent(in) :: mci_work integer, intent(in) :: phs_channel integer :: c, c_sf call k%phs%evaluate_other_channels (phs_channel) do c = 1, k%n_channel c_sf = k%phs%config%get_sf_channel (c) k%f(c) = k%sf_chain%get_f (c_sf) * k%phs%get_f (c) end do end subroutine kinematics_compute_other_channels @ %def kinematics_compute_other_channels @ Just fetch the outgoing momenta of the [[sf_chain]] subobject, which become the incoming (seed) momenta of the hard interaction. This is a stripped down-version of the above which we use when recovering kinematics. Momenta are known, but no MC parameters yet. (We do not use the [[get_out_momenta]] method of the chain, since this relies on the structure-function interactions, which are not necessary filled here. We do rely on the momenta of the last evaluator in the chain, however.) <>= procedure :: get_incoming_momenta => kinematics_get_incoming_momenta <>= module subroutine kinematics_get_incoming_momenta (k, p) class(kinematics_t), intent(in) :: k type(vector4_t), dimension(:), intent(out) :: p end subroutine kinematics_get_incoming_momenta <>= module subroutine kinematics_get_incoming_momenta (k, p) class(kinematics_t), intent(in) :: k type(vector4_t), dimension(:), intent(out) :: p type(interaction_t), pointer :: int integer :: i int => k%sf_chain%get_out_int_ptr () do i = 1, k%n_in p(i) = int%get_momentum (k%sf_chain%get_out_i (i)) end do end subroutine kinematics_get_incoming_momenta @ %def kinematics_get_incoming_momenta @ <>= procedure :: get_boost_to_lab => kinematics_get_boost_to_lab <>= module function kinematics_get_boost_to_lab (kin) result (lt) type(lorentz_transformation_t) :: lt class(kinematics_t), intent(in) :: kin end function kinematics_get_boost_to_lab <>= module function kinematics_get_boost_to_lab (kin) result (lt) type(lorentz_transformation_t) :: lt class(kinematics_t), intent(in) :: kin lt = kin%phs%get_lorentz_transformation () end function kinematics_get_boost_to_lab @ %def kinematics_get_boost_to_lab @ <>= procedure :: get_boost_to_cms => kinematics_get_boost_to_cms <>= module function kinematics_get_boost_to_cms (kin) result (lt) type(lorentz_transformation_t) :: lt class(kinematics_t), intent(in) :: kin end function kinematics_get_boost_to_cms <>= module function kinematics_get_boost_to_cms (kin) result (lt) type(lorentz_transformation_t) :: lt class(kinematics_t), intent(in) :: kin lt = inverse (kin%phs%get_lorentz_transformation ()) end function kinematics_get_boost_to_cms @ %def kinematics_get_boost_to_cms @ This inverts the remainder of the above [[compute]] method. We know the momenta and recover the rest, as far as needed. If we select a channel, we can complete the inversion and reconstruct the MC parameter set. <>= procedure :: recover_mcpar => kinematics_recover_mcpar <>= module subroutine kinematics_recover_mcpar (k, mci_work, phs_channel, p) class(kinematics_t), intent(inout) :: k type(mci_work_t), intent(inout) :: mci_work integer, intent(in) :: phs_channel type(vector4_t), dimension(:), intent(in) :: p end subroutine kinematics_recover_mcpar <>= module subroutine kinematics_recover_mcpar (k, mci_work, phs_channel, p) class(kinematics_t), intent(inout) :: k type(mci_work_t), intent(inout) :: mci_work integer, intent(in) :: phs_channel type(vector4_t), dimension(:), intent(in) :: p integer :: c, c_sf real(default), dimension(:), allocatable :: x_sf, x_phs c = phs_channel c_sf = k%phs%config%get_sf_channel (c) k%selected_channel = c call k%sf_chain%recover_kinematics (c_sf) call k%phs%set_incoming_momenta (p(1:k%n_in)) call k%phs%compute_flux () call k%phs%set_outgoing_momenta (p(k%n_in+1:)) call k%phs%inverse () do c = 1, k%n_channel c_sf = k%phs%config%get_sf_channel (c) k%f(c) = k%sf_chain%get_f (c_sf) * k%phs%get_f (c) end do k%phs_factor = k%phs%get_overall_factor () c = phs_channel c_sf = k%phs%config%get_sf_channel (c) allocate (x_sf (k%sf_chain%config%get_n_bound ())) allocate (x_phs (k%phs%config%get_n_par ())) call k%phs%select_channel (c) call k%sf_chain%get_mcpar (c_sf, x_sf) call k%phs%get_mcpar (c, x_phs) call mci_work%set_x_strfun (x_sf) call mci_work%set_x_process (x_phs) end subroutine kinematics_recover_mcpar @ %def kinematics_recover_mcpar @ This first part of [[recover_mcpar]]: just handle the sfchain. <>= procedure :: recover_sfchain => kinematics_recover_sfchain <>= module subroutine kinematics_recover_sfchain (k, channel, p) class(kinematics_t), intent(inout) :: k integer, intent(in) :: channel type(vector4_t), dimension(:), intent(in) :: p end subroutine kinematics_recover_sfchain <>= module subroutine kinematics_recover_sfchain (k, channel, p) class(kinematics_t), intent(inout) :: k integer, intent(in) :: channel type(vector4_t), dimension(:), intent(in) :: p k%selected_channel = channel call k%sf_chain%recover_kinematics (channel) end subroutine kinematics_recover_sfchain @ %def kinematics_recover_sfchain @ Retrieve the MC input parameter array for a specific channel. We assume that the kinematics is complete, so this is known for all channels. <>= procedure :: get_mcpar => kinematics_get_mcpar <>= module subroutine kinematics_get_mcpar (k, phs_channel, r) class(kinematics_t), intent(in) :: k integer, intent(in) :: phs_channel real(default), dimension(:), intent(out) :: r end subroutine kinematics_get_mcpar <>= module subroutine kinematics_get_mcpar (k, phs_channel, r) class(kinematics_t), intent(in) :: k integer, intent(in) :: phs_channel real(default), dimension(:), intent(out) :: r integer :: sf_channel, n_par_sf, n_par_phs sf_channel = k%phs%config%get_sf_channel (phs_channel) n_par_phs = k%phs%config%get_n_par () n_par_sf = k%sf_chain%config%get_n_bound () if (n_par_sf > 0) then call k%sf_chain%get_mcpar (sf_channel, r(1:n_par_sf)) end if if (n_par_phs > 0) then call k%phs%get_mcpar (phs_channel, r(n_par_sf+1:)) end if end subroutine kinematics_get_mcpar @ %def kinematics_get_mcpar @ Evaluate the structure function chain, assuming that kinematics is known. The status must be precisely [[SF_DONE_KINEMATICS]]. We thus avoid evaluating the chain twice via different pointers to the same target. <>= procedure :: evaluate_sf_chain => kinematics_evaluate_sf_chain <>= module subroutine kinematics_evaluate_sf_chain & (k, fac_scale, negative_sf, sf_rescale) class(kinematics_t), intent(inout) :: k real(default), intent(in) :: fac_scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(inout), optional :: sf_rescale end subroutine kinematics_evaluate_sf_chain <>= module subroutine kinematics_evaluate_sf_chain & (k, fac_scale, negative_sf, sf_rescale) class(kinematics_t), intent(inout) :: k real(default), intent(in) :: fac_scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(inout), optional :: sf_rescale select case (k%sf_chain%get_status ()) case (SF_DONE_KINEMATICS) call k%sf_chain%evaluate (fac_scale, negative_sf = negative_sf, & sf_rescale = sf_rescale) end select end subroutine kinematics_evaluate_sf_chain @ %def kinematics_evaluate_sf_chain @ Recover beam momenta, i.e., return the beam momenta stored in the current [[sf_chain]] to their source. This is a side effect. <>= procedure :: return_beam_momenta => kinematics_return_beam_momenta <>= module subroutine kinematics_return_beam_momenta (k) class(kinematics_t), intent(in) :: k end subroutine kinematics_return_beam_momenta <>= module subroutine kinematics_return_beam_momenta (k) class(kinematics_t), intent(in) :: k call k%sf_chain%return_beam_momenta () end subroutine kinematics_return_beam_momenta @ %def kinematics_return_beam_momenta @ Check wether the phase space is configured in the center-of-mass frame. Relevant for using the proper momenta input for BLHA matrix elements. <>= procedure :: lab_is_cm => kinematics_lab_is_cm <>= module function kinematics_lab_is_cm (k) result (lab_is_cm) logical :: lab_is_cm class(kinematics_t), intent(in) :: k end function kinematics_lab_is_cm <>= module function kinematics_lab_is_cm (k) result (lab_is_cm) logical :: lab_is_cm class(kinematics_t), intent(in) :: k lab_is_cm = k%phs%config%lab_is_cm end function kinematics_lab_is_cm @ %def kinematics_lab_is_cm @ <>= procedure :: modify_momenta_for_subtraction => & kinematics_modify_momenta_for_subtraction <>= module subroutine kinematics_modify_momenta_for_subtraction (k, p_in, p_out) class(kinematics_t), intent(inout) :: k type(vector4_t), intent(in), dimension(:) :: p_in type(vector4_t), intent(out), dimension(:), allocatable :: p_out end subroutine kinematics_modify_momenta_for_subtraction <>= module subroutine kinematics_modify_momenta_for_subtraction (k, p_in, p_out) class(kinematics_t), intent(inout) :: k type(vector4_t), intent(in), dimension(:) :: p_in type(vector4_t), intent(out), dimension(:), allocatable :: p_out allocate (p_out (size (p_in))) if (k%threshold) then select type (phs => k%phs) type is (phs_fks_t) p_out = phs%get_onshell_projected_momenta () end select else p_out = p_in end if end subroutine kinematics_modify_momenta_for_subtraction @ %def kinematics_modify_momenta_for_subtraction @ <>= procedure :: threshold_projection => kinematics_threshold_projection <>= module subroutine kinematics_threshold_projection (k, pcm_work, nlo_type) class(kinematics_t), intent(inout) :: k type(pcm_nlo_workspace_t), intent(inout) :: pcm_work integer, intent(in) :: nlo_type end subroutine kinematics_threshold_projection <>= module subroutine kinematics_threshold_projection (k, pcm_work, nlo_type) class(kinematics_t), intent(inout) :: k type(pcm_nlo_workspace_t), intent(inout) :: pcm_work integer, intent(in) :: nlo_type real(default) :: sqrts, mtop type(lorentz_transformation_t) :: L_to_cms type(vector4_t), dimension(:), allocatable :: p_tot, p_onshell integer :: n_tot n_tot = k%phs%get_n_tot () allocate (p_tot (size (pcm_work%real_kinematics%p_born_cms%phs_point(1)))) select type (phs => k%phs) type is (phs_fks_t) p_tot = pcm_work%real_kinematics%p_born_cms%phs_point(1) class default p_tot(1 : k%n_in) = phs%p p_tot(k%n_in + 1 : n_tot) = phs%q end select sqrts = sum (p_tot (1:k%n_in))**1 mtop = m1s_to_mpole (sqrts) L_to_cms = get_boost_for_threshold_projection (p_tot, sqrts, mtop) call pcm_work%real_kinematics%p_born_cms%set_momenta (1, p_tot) p_onshell = pcm_work%real_kinematics%p_born_onshell%phs_point(1) call threshold_projection_born (mtop, L_to_cms, p_tot, p_onshell) pcm_work%real_kinematics%p_born_onshell%phs_point(1) = p_onshell if (debug2_active (D_THRESHOLD)) then print *, 'On-shell projected Born: ' call vector4_write_set (p_onshell) end if end subroutine kinematics_threshold_projection @ %def kinematics_threshold_projection @ <>= procedure :: evaluate_radiation => kinematics_evaluate_radiation <>= module subroutine kinematics_evaluate_radiation (k, p_in, p_out, success) class(kinematics_t), intent(inout) :: k type(vector4_t), intent(in), dimension(:) :: p_in type(vector4_t), intent(out), dimension(:), allocatable :: p_out logical, intent(out) :: success end subroutine kinematics_evaluate_radiation <>= module subroutine kinematics_evaluate_radiation (k, p_in, p_out, success) class(kinematics_t), intent(inout) :: k type(vector4_t), intent(in), dimension(:) :: p_in type(vector4_t), intent(out), dimension(:), allocatable :: p_out logical, intent(out) :: success type(vector4_t), dimension(:), allocatable :: p_real type(vector4_t), dimension(:), allocatable :: p_born real(default) :: xi_max_offshell, xi_offshell, y_offshell, jac_rand_dummy, phi select type (phs => k%phs) type is (phs_fks_t) allocate (p_born (size (p_in))) if (k%threshold) then p_born = phs%get_onshell_projected_momenta () else p_born = p_in end if if (.not. k%phs%lab_is_cm () .and. .not. k%threshold) then p_born = inverse (k%phs%lt_cm_to_lab) * p_born end if call phs%compute_xi_max (p_born, k%threshold) if (k%emitter >= 0) then allocate (p_real (size (p_born) + 1)) allocate (p_out (size (p_born) + 1)) if (k%emitter <= k%n_in) then call phs%generate_isr (k%i_phs, p_real) else if (k%threshold) then jac_rand_dummy = 1._default call compute_y_from_emitter (phs%generator%real_kinematics%x_rad (I_Y), & phs%generator%real_kinematics%p_born_cms%get_momenta(1), & k%n_in, k%emitter, .false., phs%generator%y_max, jac_rand_dummy, & y_offshell) call phs%compute_xi_max (k%emitter, k%i_phs, y_offshell, & phs%generator%real_kinematics%p_born_cms%get_momenta(1), & xi_max_offshell) xi_offshell = xi_max_offshell * phs%generator%real_kinematics%xi_tilde phi = phs%generator%real_kinematics%phi call phs%generate_fsr (k%emitter, k%i_phs, p_real, & xi_y_phi = [xi_offshell, y_offshell, phi], no_jacobians = .true.) call phs%generator%real_kinematics%p_real_cms%set_momenta (k%i_phs, p_real) call phs%generate_fsr_threshold (k%emitter, k%i_phs, p_real) if (debug2_active (D_SUBTRACTION)) & call generate_fsr_threshold_for_other_emitters (k%emitter, k%i_phs) else if (k%i_con > 0) then call phs%generate_fsr (k%emitter, k%i_phs, p_real, k%i_con) else call phs%generate_fsr (k%emitter, k%i_phs, p_real) end if end if success = check_scalar_products (p_real) if (debug2_active (D_SUBTRACTION)) then call msg_debug2 (D_SUBTRACTION, "Real phase-space: ") call vector4_write_set (p_real) end if p_out = p_real else allocate (p_out (size (p_in))); p_out = p_in success = .true. end if end select contains subroutine generate_fsr_threshold_for_other_emitters (emitter, i_phs) integer, intent(in) :: emitter, i_phs integer :: ii_phs, this_emitter select type (phs => k%phs) type is (phs_fks_t) do ii_phs = 1, size (phs%phs_identifiers) this_emitter = phs%phs_identifiers(ii_phs)%emitter if (ii_phs /= i_phs .and. this_emitter /= emitter) & call phs%generate_fsr_threshold (this_emitter, i_phs) end do end select end subroutine end subroutine kinematics_evaluate_radiation @ %def kinematics_evaluate_radiation @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Instances} <<[[instances.f90]]>>= <> module instances <> <> use lorentz use mci_base use particles use sm_qcd, only: qcd_t use quantum_numbers use interactions use model_data use variables use sf_base use pdf, only: pdf_data_t use physics_defs use process_constants use state_matrices use phs_base use prc_core, only: prc_core_t, prc_core_state_t !!! local modules use parton_states use process_counter use pcm_base use pcm use process_config use process_mci use process use kinematics <> <> <> <> interface <> end interface contains <> end module instances @ %def instances @ <<[[instances_sub.f90]]>>= <> submodule (instances) instances_s <> use io_units use format_utils, only: write_separator use constants use diagnostics use numeric_utils use helicities use flavors use pdg_arrays, only: is_quark, is_charged_lepton, flv_eqv_expr_class !!! We should depend less on these modules (move it to pcm_nlo_t e.g.) use phs_wood, only: phs_wood_t use phs_fks use blha_olp_interfaces, only: prc_blha_t use blha_config, only: BLHA_AMP_COLOR_C use prc_external, only: prc_external_t, prc_external_state_t use prc_threshold, only: prc_threshold_t use blha_olp_interfaces, only: blha_result_array_size use prc_openloops, only: prc_openloops_t, openloops_state_t use prc_recola, only: prc_recola_t use blha_olp_interfaces, only: blha_color_c_fill_offdiag, blha_color_c_fill_diag use ttv_formfactors, only: m1s_to_mpole implicit none contains <> end submodule instances_s @ %def instances_s @ \subsection{Term instance} A [[term_instance_t]] object contains all data that describe a term. Each process component consists of one or more distinct terms which may differ in kinematics, but whose squared transition matrices have to be added pointwise. The [[active]] flag is set when this term is connected to an active process component. Inactive terms are skipped for kinematics and evaluation. The [[amp]] array stores the amplitude values when we get them from evaluating the associated matrix-element code. The [[int_hard]] interaction describes the elementary hard process. It receives the momenta and the amplitude entries for each sampling point. The [[isolated]] object holds the effective parton state for the elementary interaction. The amplitude entries are computed from [[int_hard]]. The [[connected]] evaluator set convolutes this scattering matrix with the beam (and possibly structure-function) density matrix. The [[checked]] flag is set once we have applied cuts on this term. The result of this is stored in the [[passed]] flag. Although each [[term_instance]] carries a [[weight]], this currently always keeps the value $1$ and is only used to be given to routines to fulfill their signature. <>= type :: term_instance_t type(process_term_t), pointer :: config => null () class(pcm_t), pointer :: pcm => null () class(pcm_workspace_t), pointer :: pcm_work => null () logical :: active = .false. complex(default), dimension(:), allocatable :: amp type(interaction_t) :: int_hard type(isolated_state_t) :: isolated type(connected_state_t) :: connected class(prc_core_state_t), allocatable :: core_state logical :: checked = .false. logical :: passed = .false. logical, dimension(:), allocatable :: passed_array integer, dimension(:), allocatable :: i_flv_to_i_flv_rep real(default) :: scale = 0 real(default), allocatable :: fac_scale real(default), allocatable :: ren_scale real(default), allocatable :: es_scale real(default), allocatable :: alpha_qcd_forced real(default) :: weight = 1 type(vector4_t), dimension(:), allocatable :: p_seed type(vector4_t), dimension(:), allocatable :: p_hard integer :: nlo_type = BORN integer, dimension(:), allocatable :: same_kinematics logical :: negative_sf = .false. logical :: flv_dep_cut_eval = .false. contains <> end type term_instance_t @ %def term_instance_t @ <>= procedure :: write => term_instance_write <>= module subroutine term_instance_write & (term, unit, kin, show_eff_state, testflag) class(term_instance_t), intent(in) :: term integer, intent(in), optional :: unit type(kinematics_t), intent(in), optional :: kin logical, intent(in), optional :: show_eff_state logical, intent(in), optional :: testflag end subroutine term_instance_write <>= module subroutine term_instance_write & (term, unit, kin, show_eff_state, testflag) class(term_instance_t), intent(in) :: term integer, intent(in), optional :: unit type(kinematics_t), intent(in), optional :: kin logical, intent(in), optional :: show_eff_state logical, intent(in), optional :: testflag real(default) :: fac_scale, ren_scale integer :: u logical :: state u = given_output_unit (unit) state = .true.; if (present (show_eff_state)) state = show_eff_state if (term%active) then if (associated (term%config)) then write (u, "(1x,A,I0,A,I0,A)") "Term #", term%config%i_term, & " (component #", term%config%i_component, ")" else write (u, "(1x,A)") "Term [undefined]" end if else write (u, "(1x,A,I0,A)") "Term #", term%config%i_term, & " [inactive]" end if if (term%checked) then write (u, "(3x,A,L1)") "passed cuts = ", term%passed end if if (term%passed) then write (u, "(3x,A,ES19.12)") "overall scale = ", term%scale write (u, "(3x,A,ES19.12)") "factorization scale = ", term%get_fac_scale () write (u, "(3x,A,ES19.12)") "renormalization scale = ", term%get_ren_scale () if (allocated (term%alpha_qcd_forced)) then write (u, "(3x,A,ES19.12)") "alpha(QCD) forced = ", & term%alpha_qcd_forced end if write (u, "(3x,A,ES19.12)") "reweighting factor = ", term%weight end if !!! This used to be a member of term_instance if (present (kin)) then call kin%write (u) end if call write_separator (u) write (u, "(1x,A)") "Amplitude (transition matrix of the & &hard interaction):" call write_separator (u) call term%int_hard%basic_write (u, testflag = testflag) if (state .and. term%isolated%has_trace) then call write_separator (u) write (u, "(1x,A)") "Evaluators for the hard interaction:" call term%isolated%write (u, testflag = testflag) end if if (state .and. term%connected%has_trace) then call write_separator (u) write (u, "(1x,A)") "Evaluators for the connected process:" call term%connected%write (u, testflag = testflag) end if end subroutine term_instance_write @ %def term_instance_write @ The interactions and evaluators must be finalized. <>= procedure :: final => term_instance_final <>= module subroutine term_instance_final (term) class(term_instance_t), intent(inout) :: term end subroutine term_instance_final <>= module subroutine term_instance_final (term) class(term_instance_t), intent(inout) :: term if (allocated (term%amp)) deallocate (term%amp) if (allocated (term%core_state)) deallocate (term%core_state) if (allocated (term%ren_scale)) deallocate (term%ren_scale) if (allocated (term%fac_scale)) deallocate (term%fac_scale) if (allocated (term%es_scale)) deallocate (term%es_scale) if (allocated (term%alpha_qcd_forced)) & deallocate (term%alpha_qcd_forced) if (allocated (term%p_seed)) deallocate(term%p_seed) if (allocated (term%p_hard)) deallocate (term%p_hard) call term%connected%final () call term%isolated%final () call term%int_hard%final () term%pcm => null () term%pcm_work => null () end subroutine term_instance_final @ %def term_instance_final @ For a new term object, we configure the structure-function interface, the phase space, the matrix-element (interaction) interface, etc. <>= procedure :: configure => term_instance_configure <>= module subroutine term_instance_configure & (term_instance, process, i, pcm_work, sf_chain, kin) class(term_instance_t), intent(out), target :: term_instance type(process_t), intent(in), target :: process integer, intent(in) :: i class(pcm_workspace_t), intent(in), target :: pcm_work type(sf_chain_t), intent(in), target :: sf_chain type(kinematics_t), intent(inout), target :: kin end subroutine term_instance_configure <>= module subroutine term_instance_configure & (term_instance, process, i, pcm_work, sf_chain, kin) class(term_instance_t), intent(out), target :: term_instance type(process_t), intent(in), target :: process integer, intent(in) :: i class(pcm_workspace_t), intent(in), target :: pcm_work type(sf_chain_t), intent(in), target :: sf_chain type(kinematics_t), intent(inout), target :: kin type(process_term_t) :: term integer :: i_component logical :: requires_extended_sf term = process%get_term_ptr (i) i_component = term%i_component if (i_component /= 0) then call term_instance%init & (process%get_pcm_ptr (), pcm_work, process%get_nlo_type_component (i_component)) requires_extended_sf = term_instance%nlo_type == NLO_DGLAP .or. & (term_instance%nlo_type == NLO_REAL .and. process%get_i_sub (i) == i) call term_instance%setup_dynamics (process, i, kin, & real_finite = process%component_is_real_finite (i_component)) select type (phs => kin%phs) type is (phs_fks_t) call term_instance%set_emitter (kin) call term_instance%setup_fks_kinematics (kin, & process%get_var_list_ptr (), & process%get_beam_config_ptr ()) end select select type (pcm => term_instance%pcm) type is (pcm_nlo_t) call kin%set_threshold (pcm%settings%factorization_mode) end select call term_instance%setup_expressions (process%get_meta (), process%get_config ()) end if end subroutine term_instance_configure @ %def term_instance_configure @ First part of term-instance configuration: initialize by assigning pointers to the overall [[pcm]] and the associated [[pcm_workspace]] objects. <>= procedure :: init => term_instance_init <>= module subroutine term_instance_init & (term_instance, pcm, pcm_work, nlo_type) class(term_instance_t), intent(out) :: term_instance class(pcm_t), intent(in), target :: pcm class(pcm_workspace_t), intent(in), target :: pcm_work integer, intent(in) :: nlo_type end subroutine term_instance_init <>= module subroutine term_instance_init (term_instance, pcm, pcm_work, nlo_type) class(term_instance_t), intent(out) :: term_instance class(pcm_t), intent(in), target :: pcm class(pcm_workspace_t), intent(in), target :: pcm_work integer, intent(in) :: nlo_type term_instance%pcm => pcm term_instance%pcm_work => pcm_work term_instance%nlo_type = nlo_type end subroutine term_instance_init @ %def term_instance_init @ The second part of term-instance configuration concerns dynamics, i.e., the interface to the matrix-element (interaction), and the parton-state objects that combine all kinematics and matrix-element data for evaluation. The hard interaction (incoming momenta) is linked to the structure function instance. In the isolated state, we either set pointers to both, or we create modified copies ([[rearrange]]) as effective structure-function chain and interaction, respectively. Finally, we set up the [[subevt]] component that will be used for evaluating observables, collecting particles from the trace evaluator in the effective connected state. Their quantum numbers must be determined by following back source links and set explicitly, since they are already eliminated in that trace. The [[rearrange]] parts are still commented out; they could become relevant for a NLO algorithm. <>= procedure :: setup_dynamics => term_instance_setup_dynamics <>= module subroutine term_instance_setup_dynamics & (term, process, i_term, kin, real_finite) class(term_instance_t), intent(inout), target :: term type(process_t), intent(in), target:: process integer, intent(in) :: i_term type(kinematics_t), intent(in) :: kin logical, intent(in), optional :: real_finite end subroutine term_instance_setup_dynamics <>= module subroutine term_instance_setup_dynamics & (term, process, i_term, kin, real_finite) class(term_instance_t), intent(inout), target :: term type(process_t), intent(in), target:: process integer, intent(in) :: i_term type(kinematics_t), intent(in) :: kin logical, intent(in), optional :: real_finite class(prc_core_t), pointer :: core => null () type(process_beam_config_t) :: beam_config type(interaction_t), pointer :: sf_chain_int type(interaction_t), pointer :: src_int type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in type(state_matrix_t), pointer :: state_matrix type(flavor_t), dimension(:), allocatable :: flv_int, flv_src, f_in, f_out integer, dimension(:,:), allocatable :: flv_born, flv_real type(flavor_t), dimension(:,:), allocatable :: flv_pdf type(quantum_numbers_t), dimension(:,:), allocatable :: qn_pdf integer :: n_in, n_vir, n_out, n_tot, n_sub integer :: n_flv_born, n_flv_real, n_flv_total integer :: i, j logical :: me_already_squared, keep_fs_flavors logical :: decrease_n_tot logical :: requires_extended_sf me_already_squared = .false. keep_fs_flavors = .false. term%config => process%get_term_ptr (i_term) term%int_hard = term%config%int core => process%get_core_term (i_term) term%negative_sf = process%get_negative_sf () call core%allocate_workspace (term%core_state) select type (core) class is (prc_external_t) call reduce_interaction (term%int_hard, & core%includes_polarization (), .true., .false.) me_already_squared = .true. allocate (term%amp (term%int_hard%get_n_matrix_elements ())) class default allocate (term%amp (term%config%n_allowed)) end select if (allocated (term%core_state)) then select type (core_state => term%core_state) type is (openloops_state_t) call core_state%init_threshold (process%get_model_ptr ()) end select end if term%amp = cmplx (0, 0, default) decrease_n_tot = term%nlo_type == NLO_REAL .and. & term%config%i_term_global /= term%config%i_sub if (present (real_finite)) then if (real_finite) decrease_n_tot = .false. end if if (decrease_n_tot) then allocate (term%p_seed (term%int_hard%get_n_tot () - 1)) else allocate (term%p_seed (term%int_hard%get_n_tot ())) end if allocate (term%p_hard (term%int_hard%get_n_tot ())) sf_chain_int => kin%sf_chain%get_out_int_ptr () n_in = term%int_hard%get_n_in () do j = 1, n_in i = kin%sf_chain%get_out_i (j) call term%int_hard%set_source_link (j, sf_chain_int, i) end do call term%isolated%init (kin%sf_chain, term%int_hard) allocate (mask_in (n_in)) mask_in = kin%sf_chain%get_out_mask () select type (phs => kin%phs) type is (phs_wood_t) if (me_already_squared) then call term%isolated%setup_identity_trace & (core, mask_in, .true., .false.) else call term%isolated%setup_square_trace & (core, mask_in, term%config%col, .false.) end if type is (phs_fks_t) select case (phs%mode) case (PHS_MODE_ADDITIONAL_PARTICLE) if (me_already_squared) then call term%isolated%setup_identity_trace & (core, mask_in, .true., .false.) else keep_fs_flavors = term%config%data%n_flv > 1 call term%isolated%setup_square_trace & (core, mask_in, term%config%col, & keep_fs_flavors) end if case (PHS_MODE_COLLINEAR_REMNANT) if (me_already_squared) then call term%isolated%setup_identity_trace & (core, mask_in, .true., .false.) else call term%isolated%setup_square_trace & (core, mask_in, term%config%col, .false.) end if end select class default call term%isolated%setup_square_trace & (core, mask_in, term%config%col, .false.) end select if (term%nlo_type == NLO_VIRTUAL .or. (term%nlo_type == NLO_REAL .and. & term%config%i_term_global == term%config%i_sub) .or. & term%nlo_type == NLO_MISMATCH) then n_sub = term%get_n_sub () else if (term%nlo_type == NLO_DGLAP) then n_sub = n_beams_rescaled + term%get_n_sub () else !!! No integration of real subtraction in interactions yet n_sub = 0 end if keep_fs_flavors = keep_fs_flavors .or. me_already_squared requires_extended_sf = term%nlo_type == NLO_DGLAP .or. & (term%is_subtraction () .and. process%pcm_contains_pdfs ()) call term%connected%setup_connected_trace (term%isolated, & undo_helicities = undo_helicities (core, me_already_squared), & keep_fs_flavors = keep_fs_flavors, & requires_extended_sf = requires_extended_sf) associate (int_eff => term%isolated%int_eff) state_matrix => int_eff%get_state_matrix_ptr () n_tot = int_eff%get_n_tot () flv_int = quantum_numbers_get_flavor & (state_matrix%get_quantum_number (1)) allocate (f_in (n_in)) f_in = flv_int(1:n_in) deallocate (flv_int) end associate n_in = term%connected%trace%get_n_in () n_vir = term%connected%trace%get_n_vir () n_out = term%connected%trace%get_n_out () allocate (f_out (n_out)) do j = 1, n_out call term%connected%trace%find_source & (n_in + n_vir + j, src_int, i) if (associated (src_int)) then state_matrix => src_int%get_state_matrix_ptr () flv_src = quantum_numbers_get_flavor & (state_matrix%get_quantum_number (1)) f_out(j) = flv_src(i) deallocate (flv_src) end if end do beam_config = process%get_beam_config () select type (pcm => term%pcm) type is (pcm_nlo_t) term%flv_dep_cut_eval = pcm%settings%nlo_correction_type == "EW" & .and. pcm%region_data%alphas_power > 0 & .and. any(is_charged_lepton(f_out%get_pdg())) end select call term%connected%setup_subevt (term%isolated%sf_chain_eff, & beam_config%data%flv, f_in, f_out) call term%connected%setup_var_list & (process%get_var_list_ptr (), beam_config%data) ! Does connected%trace never have any helicity qn? call term%init_interaction_qn_index (core, term%connected%trace, n_sub, & process%get_model_ptr (), is_polarized = .false.) call term%init_interaction_qn_index & (core, term%int_hard, n_sub, process%get_model_ptr ()) call term%init_eqv_expr_classes () if (requires_extended_sf) then select type (pcm => term%pcm) type is (pcm_nlo_t) n_in = pcm%region_data%get_n_in () flv_born = pcm%region_data%get_flv_states_born () flv_real = pcm%region_data%get_flv_states_real () n_flv_born = pcm%region_data%get_n_flv_born () n_flv_real = pcm%region_data%get_n_flv_real () n_flv_total = n_flv_born + n_flv_real allocate (flv_pdf(n_in, n_flv_total), & qn_pdf(n_in, n_flv_total)) call flv_pdf(:, :n_flv_born)%init (flv_born(:n_in, :)) call flv_pdf(:, n_flv_born + 1:n_flv_total)%init (flv_real(:n_in, :)) call qn_pdf%init (flv_pdf) call sf_chain_int%init_qn_index (qn_pdf, n_flv_born, n_flv_real) end select end if contains function undo_helicities (core, me_squared) result (val) logical :: val class(prc_core_t), intent(in) :: core logical, intent(in) :: me_squared select type (core) class is (prc_external_t) val = me_squared .and. .not. core%includes_polarization () class default val = .false. end select end function undo_helicities subroutine reduce_interaction (int, polarized_beams, keep_fs_flavors, & keep_colors) type(interaction_t), intent(inout) :: int logical, intent(in) :: polarized_beams logical, intent(in) :: keep_fs_flavors, keep_colors type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask logical, dimension(:), allocatable :: mask_f, mask_c, mask_h integer :: n_tot, n_in n_in = int%get_n_in (); n_tot = int%get_n_tot () allocate (qn_mask (n_tot)) allocate (mask_f (n_tot), mask_c (n_tot), mask_h (n_tot)) mask_c = .not. keep_colors mask_f (1 : n_in) = .false. if (keep_fs_flavors) then mask_f (n_in + 1 : ) = .false. else mask_f (n_in + 1 : ) = .true. end if if (polarized_beams) then mask_h (1 : n_in) = .false. else mask_h (1 : n_in) = .true. end if mask_h (n_in + 1 : ) = .true. call qn_mask%init (mask_f, mask_c, mask_h) call int%reduce_state_matrix (qn_mask, keep_order = .true.) end subroutine reduce_interaction end subroutine term_instance_setup_dynamics @ %def term_instance_setup_dynamics @ Set up index mapping from state matrix to index pair [[i_flv]], [[i_sub]]. <>= public :: setup_interaction_qn_index <>= module subroutine setup_interaction_qn_index & (int, data, qn_config, n_sub, is_polarized) class(interaction_t), intent(inout) :: int class(process_constants_t), intent(in) :: data type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_config integer, intent(in) :: n_sub logical, intent(in) :: is_polarized end subroutine setup_interaction_qn_index <>= module subroutine setup_interaction_qn_index & (int, data, qn_config, n_sub, is_polarized) class(interaction_t), intent(inout) :: int class(process_constants_t), intent(in) :: data type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_config integer, intent(in) :: n_sub logical, intent(in) :: is_polarized integer :: i type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel if (is_polarized) then call setup_interaction_qn_hel (int, data, qn_hel) call int%init_qn_index (qn_config, n_sub, qn_hel) call int%set_qn_index_helicity_flip (.true.) else call int%init_qn_index (qn_config, n_sub) end if end subroutine setup_interaction_qn_index @ %def setup_interaction_qn_index @ Set up beam polarisation quantum numbers, if beam polarisation is required. We retrieve the full helicity information from [[term%config%data]] and reduce the information only to the inital state. Afterwards, we uniquify the initial state polarization by a applying an index (hash) table. The helicity information is fed into an array of quantum numbers to assign flavor, helicity and subtraction indices correctly to their matrix element. <>= public :: setup_interaction_qn_hel <>= module subroutine setup_interaction_qn_hel (int, data, qn_hel) class(interaction_t), intent(in) :: int class(process_constants_t), intent(in) :: data type(quantum_numbers_t), dimension(:, :), allocatable, intent(out) :: & qn_hel end subroutine setup_interaction_qn_hel <>= module subroutine setup_interaction_qn_hel (int, data, qn_hel) class(interaction_t), intent(in) :: int class(process_constants_t), intent(in) :: data type(quantum_numbers_t), dimension(:, :), allocatable, intent(out) :: & qn_hel type(helicity_t), dimension(:), allocatable :: hel integer, dimension(:), allocatable :: index_table integer, dimension(:, :), allocatable :: hel_state integer :: i, j, n_hel_unique associate (n_in => int%get_n_in (), n_tot => int%get_n_tot ()) allocate (hel_state (n_tot, data%get_n_hel ()), & source = data%hel_state) allocate (index_table (data%get_n_hel ()), & source = 0) forall (j=1:data%get_n_hel (), i=n_in+1:n_tot) hel_state(i, j) = 0 n_hel_unique = 0 HELICITY: do i = 1, data%get_n_hel () do j = 1, data%get_n_hel () if (index_table (j) == 0) then index_table(j) = i; n_hel_unique = n_hel_unique + 1 cycle HELICITY else if (all (hel_state(:, i) == & hel_state(:, index_table(j)))) then cycle HELICITY end if end do end do HELICITY allocate (qn_hel (n_tot, n_hel_unique)) allocate (hel (n_tot)) do j = 1, n_hel_unique call hel%init (hel_state(:, index_table(j))) call qn_hel(:, j)%init (hel) end do end associate end subroutine setup_interaction_qn_hel @ %def setup_interaction_qn_hel @ Initialization of equivalent cut expression classes. Each flavor index [[i_flv]] here is assigned to the corresponding one representative for an equivalent cut expression class. This class describes the set of flavor quantum numbers for which the phase space cut expression evaluation yield the same output. The representative [[i_flv]] for one class correspond to the first flavor quantum numbers of that kind occuring in the state matrix. <>= procedure :: init_eqv_expr_classes => term_instance_init_eqv_expr_classes <>= module subroutine term_instance_init_eqv_expr_classes (term) class(term_instance_t), intent(inout), target :: term end subroutine term_instance_init_eqv_expr_classes <>= module subroutine term_instance_init_eqv_expr_classes (term) class(term_instance_t), intent(inout), target :: term type(interaction_t), pointer :: src_int type(state_matrix_t), pointer :: state_matrix type(flavor_t), dimension(:), allocatable :: flv_src logical, dimension(:,:,:), allocatable :: eqv_expr_class logical, dimension (:), allocatable :: evaluated integer :: n_in, n_vir, n_out integer :: k, j, i n_in = term%connected%trace%get_n_in () n_vir = term%connected%trace%get_n_vir () n_out = term%connected%trace%get_n_out () allocate (eqv_expr_class (3, n_out, & term%connected%trace%get_qn_index_n_flv ())) do k = 1, term%connected%trace%get_qn_index_n_flv () do j = 1, n_out call term%connected%trace%find_source & (n_in + n_vir + j, src_int, i) if (associated (src_int)) then state_matrix => src_int%get_state_matrix_ptr () flv_src = quantum_numbers_get_flavor & (state_matrix%get_quantum_number (k)) eqv_expr_class (:, j, k) = flv_eqv_expr_class (flv_src(i)%get_pdg()) deallocate (flv_src) end if end do end do if (term%flv_dep_cut_eval) then allocate (evaluated (term%connected%trace%get_qn_index_n_flv ())) evaluated = .false. allocate (term%i_flv_to_i_flv_rep (term%connected%trace%get_qn_index_n_flv ())) do i = 1, term%connected%trace%get_qn_index_n_flv () if (.not. evaluated (i)) then do k = i, term%connected%trace%get_qn_index_n_flv () if (same_eqv_expr_class(eqv_expr_class (:,:,i), eqv_expr_class (:,:,k))) then term%i_flv_to_i_flv_rep (k) = i evaluated (k) = .true. end if end do end if end do end if contains function same_eqv_expr_class (flv_mask1, flv_mask2) result (same) logical, dimension (:,:), intent(in) :: flv_mask1, flv_mask2 logical :: same integer :: l same = .true. do l = 1, size (flv_mask1, dim = 2) same = same .and. all (flv_mask1(:,l) .eqv. flv_mask2(:,l)) end do end function same_eqv_expr_class end subroutine term_instance_init_eqv_expr_classes @ %def term_instance_init_eqv_expr_classes @ <>= procedure :: init_interaction_qn_index => & term_instance_init_interaction_qn_index <>= module subroutine term_instance_init_interaction_qn_index (term, core, & int, n_sub, model, is_polarized) class(term_instance_t), intent(inout), target :: term class(prc_core_t), intent(in) :: core class(interaction_t), intent(inout) :: int integer, intent(in) :: n_sub class(model_data_t), intent(in) :: model logical, intent(in), optional :: is_polarized end subroutine term_instance_init_interaction_qn_index <>= module subroutine term_instance_init_interaction_qn_index (term, core, & int, n_sub, model, is_polarized) class(term_instance_t), intent(inout), target :: term class(prc_core_t), intent(in) :: core class(interaction_t), intent(inout) :: int integer, intent(in) :: n_sub class(model_data_t), intent(in) :: model logical, intent(in), optional :: is_polarized logical :: polarized type(quantum_numbers_t), dimension(:, :), allocatable :: qn_config integer, dimension(:,:), allocatable :: flv_born type(flavor_t), dimension(:), allocatable :: flv integer :: i select type (core) class is (prc_external_t) if (present (is_polarized)) then polarized = is_polarized else polarized = core%includes_polarization () end if select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) associate (is_born => .not. (term%nlo_type == NLO_REAL .and. & .not. term%is_subtraction ())) select type (pcm => term%pcm) type is (pcm_nlo_t) qn_config = pcm%get_qn (is_born) end select call setup_interaction_qn_index (int, term%config%data, & qn_config, n_sub, polarized) end associate class default call term%config%data%get_flv_state (flv_born) allocate (flv (size (flv_born, dim = 1))) allocate (qn_config (size (flv_born, dim = 1), size (flv_born, dim = 2))) do i = 1, core%data%n_flv call flv%init (flv_born(:,i), model) call qn_config(:, i)%init (flv) end do call setup_interaction_qn_index (int, term%config%data, & qn_config, n_sub, polarized) end select class default call int%init_qn_index () end select end subroutine term_instance_init_interaction_qn_index @ %def term_instance_init_interaction_qn_index @ <>= procedure :: setup_fks_kinematics => term_instance_setup_fks_kinematics <>= module subroutine term_instance_setup_fks_kinematics & (term, kin, var_list, beam_config) class(term_instance_t), intent(inout), target :: term type(kinematics_t), intent(inout) :: kin type(var_list_t), intent(in) :: var_list type(process_beam_config_t), intent(in) :: beam_config end subroutine term_instance_setup_fks_kinematics <>= module subroutine term_instance_setup_fks_kinematics & (term, kin, var_list, beam_config) class(term_instance_t), intent(inout), target :: term type(kinematics_t), intent(inout) :: kin type(var_list_t), intent(in) :: var_list type(process_beam_config_t), intent(in) :: beam_config integer :: mode logical :: singular_jacobian if (.not. (term%nlo_type == NLO_REAL .or. term%nlo_type == NLO_DGLAP .or. & term%nlo_type == NLO_MISMATCH)) return singular_jacobian = var_list%get_lval & (var_str ("?powheg_use_singular_jacobian")) if (term%nlo_type == NLO_REAL) then mode = check_generator_mode (GEN_REAL_PHASE_SPACE) else if (term%nlo_type == NLO_MISMATCH) then mode = check_generator_mode (GEN_SOFT_MISMATCH) else mode = PHS_MODE_UNDEFINED end if select type (phs => kin%phs) type is (phs_fks_t) select type (pcm => term%pcm) type is (pcm_nlo_t) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) call pcm%setup_phs_generator (pcm_work, & phs%generator, phs%config%sqrts, mode, singular_jacobian) if (beam_config%has_structure_function ()) then pcm_work%isr_kinematics%isr_mode = SQRTS_VAR else pcm_work%isr_kinematics%isr_mode = SQRTS_FIXED end if if (debug_on) call msg_debug & (D_PHASESPACE, "isr_mode: ", pcm_work%isr_kinematics%isr_mode) end select end select class default call msg_fatal ("Phase space should be an FKS phase space!") end select contains function check_generator_mode (gen_mode_default) result (gen_mode) integer :: gen_mode integer, intent(in) :: gen_mode_default select type (pcm => term%pcm) type is (pcm_nlo_t) associate (settings => pcm%settings) if (settings%test_coll_limit .and. settings%test_anti_coll_limit) & call msg_fatal ("You cannot check the collinear and anti-collinear limit "& &"at the same time!") if (settings%test_soft_limit .and. .not. settings%test_coll_limit & .and. .not. settings%test_anti_coll_limit) then gen_mode = GEN_SOFT_LIMIT_TEST else if (.not. settings%test_soft_limit .and. settings%test_coll_limit) then gen_mode = GEN_COLL_LIMIT_TEST else if (.not. settings%test_soft_limit .and. settings%test_anti_coll_limit) then gen_mode = GEN_ANTI_COLL_LIMIT_TEST else if (settings%test_soft_limit .and. settings%test_coll_limit) then gen_mode = GEN_SOFT_COLL_LIMIT_TEST else if (settings%test_soft_limit .and. settings%test_anti_coll_limit) then gen_mode = GEN_SOFT_ANTI_COLL_LIMIT_TEST else gen_mode = gen_mode_default end if end associate end select end function check_generator_mode end subroutine term_instance_setup_fks_kinematics @ %def term_instance_setup_fks_kinematics @ Set up seed kinematics, starting from the MC parameter set given as argument. As a result, the [[k_seed]] kinematics object is evaluated (except for the structure-function matrix-element evaluation, which we postpone until we know the factorization scale), and we have a valid [[p_seed]] momentum array. <>= procedure :: compute_seed_kinematics => term_instance_compute_seed_kinematics <>= module subroutine term_instance_compute_seed_kinematics & (term, kin, mci_work, phs_channel, success) class(term_instance_t), intent(inout), target :: term type(kinematics_t), intent(inout) :: kin type(mci_work_t), intent(in) :: mci_work integer, intent(in) :: phs_channel logical, intent(out) :: success end subroutine term_instance_compute_seed_kinematics <>= module subroutine term_instance_compute_seed_kinematics & (term, kin, mci_work, phs_channel, success) class(term_instance_t), intent(inout), target :: term type(kinematics_t), intent(inout) :: kin type(mci_work_t), intent(in) :: mci_work integer, intent(in) :: phs_channel logical, intent(out) :: success call kin%compute_selected_channel & (mci_work, phs_channel, term%p_seed, success) end subroutine term_instance_compute_seed_kinematics @ %def term_instance_compute_seed_kinematics @ <>= procedure :: evaluate_projections => term_instance_evaluate_projections <>= module subroutine term_instance_evaluate_projections (term, kin) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin end subroutine term_instance_evaluate_projections <>= module subroutine term_instance_evaluate_projections (term, kin) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin if (kin%threshold .and. term%nlo_type > BORN) then if (debug2_active (D_THRESHOLD)) & print *, 'Evaluate on-shell projection: ', & char (component_status (term%nlo_type)) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) call kin%threshold_projection (pcm_work, term%nlo_type) end select end if end subroutine term_instance_evaluate_projections @ %def term_instance_evaluate_projections @ Compute the momenta in the hard interactions, one for each term that constitutes this process component. In simple cases this amounts to just copying momenta. In more advanced cases, we may generate distinct sets of momenta from the seed kinematics. The interactions in the term instances are accessed individually. We may choose to calculate all terms at once together with the seed kinematics, use [[component%core_state]] for storage, and just fill the interactions here. <>= procedure :: compute_hard_kinematics => & term_instance_compute_hard_kinematics <>= module subroutine term_instance_compute_hard_kinematics & (term, kin, recover, skip_term, success) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin integer, intent(in), optional :: skip_term logical, intent(in), optional :: recover logical, intent(out) :: success end subroutine term_instance_compute_hard_kinematics <>= module subroutine term_instance_compute_hard_kinematics & (term, kin, recover, skip_term, success) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin integer, intent(in), optional :: skip_term logical, intent(in), optional :: recover logical, intent(out) :: success type(vector4_t), dimension(:), allocatable :: p if (allocated (term%core_state)) & call term%core_state%reset_new_kinematics () if (present (skip_term)) then if (term%config%i_term_global == skip_term) return end if if (present (recover)) then if (recover) return end if if (term%nlo_type == NLO_REAL .and. kin%emitter >= 0) then call kin%evaluate_radiation (term%p_seed, p, success) select type (pcm => term%pcm) type is (pcm_nlo_t) if (pcm%dalitz_plot%active) then if (kin%emitter > kin%n_in) then if (p(kin%emitter)**2 > tiny_07) & call pcm%register_dalitz_plot (kin%emitter, p) end if end if end select else if (is_subtraction_component (kin%emitter, term%nlo_type)) then call kin%modify_momenta_for_subtraction (term%p_seed, p) success = .true. else allocate (p (size (term%p_seed))); p = term%p_seed success = .true. end if call term%int_hard%set_momenta (p) if (debug_on) then call msg_debug2 (D_REAL, "inside compute_hard_kinematics") if (debug2_active (D_REAL)) call vector4_write_set (p) end if end subroutine term_instance_compute_hard_kinematics @ %def term_instance_compute_hard_kinematics @ Here, we invert this. We fetch the incoming momenta which reside in the appropriate [[sf_chain]] object, stored within the [[k_seed]] subobject. On the other hand, we have the outgoing momenta of the effective interaction. We rely on the process core to compute the remaining seed momenta and to fill the momenta within the hard interaction. (The latter is trivial if hard and effective interaction coincide.) After this is done, the incoming momenta in the trace evaluator that corresponds to the hard (effective) interaction, are still left undefined. We remedy this by calling [[receive_kinematics]] once. <>= procedure :: recover_seed_kinematics => & term_instance_recover_seed_kinematics <>= module subroutine term_instance_recover_seed_kinematics & (term, kin, p_seed_ref) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(in) :: kin type(vector4_t), dimension(:), intent(in), optional :: p_seed_ref end subroutine term_instance_recover_seed_kinematics <>= module subroutine term_instance_recover_seed_kinematics & (term, kin, p_seed_ref) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(in) :: kin integer :: n_in type(vector4_t), dimension(:), intent(in), optional :: p_seed_ref n_in = kin%n_in call kin%get_incoming_momenta (term%p_seed(1:n_in)) associate (int_eff => term%isolated%int_eff) call int_eff%set_momenta (term%p_seed(1:n_in), outgoing = .false.) if (present (p_seed_ref)) then term%p_seed(n_in + 1 : ) = p_seed_ref else term%p_seed(n_in + 1 : ) = int_eff%get_momenta (outgoing = .true.) end if end associate call term%isolated%receive_kinematics () end subroutine term_instance_recover_seed_kinematics @ %def term_instance_recover_seed_kinematics @ Compute the integration parameters for all channels except the selected one. JRR: Obsolete now. <>= procedure :: compute_other_channels => & term_instance_compute_other_channels <>= subroutine term_instance_compute_other_channels & (term, mci_work, phs_channel) class(term_instance_t), intent(inout), target :: term type(mci_work_t), intent(in) :: mci_work integer, intent(in) :: phs_channel call term%k_term%compute_other_channels (mci_work, phs_channel) end subroutine term_instance_compute_other_channels @ %def term_instance_compute_other_channels @ Recover beam momenta, i.e., return the beam momenta as currently stored in the kinematics subobject to their source. This is a side effect. JRR: Obsolete now. <>= procedure :: return_beam_momenta => term_instance_return_beam_momenta <>= subroutine term_instance_return_beam_momenta (term) class(term_instance_t), intent(in) :: term call term%k_term%return_beam_momenta () end subroutine term_instance_return_beam_momenta @ %def term_instance_return_beam_momenta @ Applies the real partition by computing the real partition function $F(\Phi)$ and multiplying either $\mathcal{R}_\text{sin} = \mathcal{R} \cdot F$ or $\mathcal{R}_\text{fin} = \mathcal{R} \cdot (1-F)$. <>= procedure :: apply_real_partition => term_instance_apply_real_partition <>= module subroutine term_instance_apply_real_partition (term, kin) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(in) :: kin end subroutine term_instance_apply_real_partition <>= module subroutine term_instance_apply_real_partition (term, kin) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(in) :: kin real(default) :: f, sqme integer :: i_component integer :: i_amp, n_amps, qn_index logical :: is_subtraction i_component = term%config%i_component select type (pcm => term%pcm) type is (pcm_nlo_t) if (pcm%component_selected (i_component) .and. & pcm%nlo_type (i_component) == NLO_REAL) then is_subtraction = pcm%component_type (i_component) == & COMP_REAL_SING .and. kin%emitter < 0 if (is_subtraction) return select case (pcm%component_type (i_component)) case (COMP_REAL_FIN) call term%connected%trace%set_duplicate_flv_zero() end select f = pcm%real_partition%get_f (term%p_hard) n_amps = term%connected%trace%get_n_matrix_elements () do i_amp = 1, n_amps qn_index = term%connected%trace%get_qn_index (i_amp, i_sub = 0) if (term%passed_array(i_amp) .or. .not. term%passed) then sqme = real (term%connected%trace%get_matrix_element (qn_index)) else sqme = zero end if if (debug_on) call msg_debug2 & (D_PROCESS_INTEGRATION, "term_instance_apply_real_partition") select case (pcm%component_type (i_component)) case (COMP_REAL_FIN) if (debug_on) call msg_debug2 & (D_PROCESS_INTEGRATION, "Real finite") sqme = sqme * (one - f) case (COMP_REAL_SING) if (debug_on) call msg_debug2 & (D_PROCESS_INTEGRATION, "Real singular") sqme = sqme * f end select if (debug_on) call msg_debug2 & (D_PROCESS_INTEGRATION, "apply_damping: sqme", sqme) call term%connected%trace%set_matrix_element & (qn_index, cmplx (sqme, zero, default)) end do end if end select end subroutine term_instance_apply_real_partition @ %def term_instance_apply_real_partition @ <>= procedure :: get_p_hard => term_instance_get_p_hard <>= pure module function term_instance_get_p_hard & (term_instance) result (p_hard) type(vector4_t), dimension(:), allocatable :: p_hard class(term_instance_t), intent(in) :: term_instance end function term_instance_get_p_hard <>= pure module function term_instance_get_p_hard (term_instance) result (p_hard) type(vector4_t), dimension(:), allocatable :: p_hard class(term_instance_t), intent(in) :: term_instance allocate (p_hard (size (term_instance%p_hard))) p_hard = term_instance%p_hard end function term_instance_get_p_hard @ %def term_instance_get_p_hard @ <>= procedure :: set_emitter => term_instance_set_emitter <>= module subroutine term_instance_set_emitter (term, kin) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin end subroutine term_instance_set_emitter <>= module subroutine term_instance_set_emitter (term, kin) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin integer :: i_phs logical :: set_emitter select type (pcm => term%pcm) type is (pcm_nlo_t) select type (phs => kin%phs) type is (phs_fks_t) !!! Without resonances, i_alr = i_phs i_phs = term%config%i_term kin%i_phs = i_phs set_emitter = i_phs <= pcm%region_data%n_phs .and. & term%nlo_type == NLO_REAL if (set_emitter) then kin%emitter = phs%phs_identifiers(i_phs)%emitter select type (pcm => term%pcm) type is (pcm_nlo_t) if (allocated (pcm%region_data%i_phs_to_i_con)) & kin%i_con = pcm%region_data%i_phs_to_i_con (i_phs) end select end if end select end select end subroutine term_instance_set_emitter @ %def term_instance_set_emitter @ For initializing the expressions, we need the local variable list and the parse trees. <>= procedure :: setup_expressions => term_instance_setup_expressions <>= module subroutine term_instance_setup_expressions (term, meta, config) class(term_instance_t), intent(inout), target :: term type(process_metadata_t), intent(in), target :: meta type(process_config_data_t), intent(in) :: config end subroutine term_instance_setup_expressions <>= module subroutine term_instance_setup_expressions (term, meta, config) class(term_instance_t), intent(inout), target :: term type(process_metadata_t), intent(in), target :: meta type(process_config_data_t), intent(in) :: config if (allocated (config%ef_cuts)) & call term%connected%setup_cuts (config%ef_cuts) if (allocated (config%ef_scale)) & call term%connected%setup_scale (config%ef_scale) if (allocated (config%ef_fac_scale)) & call term%connected%setup_fac_scale (config%ef_fac_scale) if (allocated (config%ef_ren_scale)) & call term%connected%setup_ren_scale (config%ef_ren_scale) if (allocated (config%ef_weight)) & call term%connected%setup_weight (config%ef_weight) end subroutine term_instance_setup_expressions @ %def term_instance_setup_expressions @ Prepare the extra evaluators that we need for processing events. The matrix elements we get from OpenLoops and GoSam are already squared and summed over color and helicity. They should not be squared again. <>= procedure :: setup_event_data => term_instance_setup_event_data <>= module subroutine term_instance_setup_event_data (term, kin, core, model) class(term_instance_t), intent(inout), target :: term type(kinematics_t), intent(in) :: kin class(prc_core_t), intent(in) :: core class(model_data_t), intent(in), target :: model end subroutine term_instance_setup_event_data <>= module subroutine term_instance_setup_event_data (term, kin, core, model) class(term_instance_t), intent(inout), target :: term type(kinematics_t), intent(in) :: kin class(prc_core_t), intent(in) :: core class(model_data_t), intent(in), target :: model integer :: n_in logical :: mask_color type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in n_in = term%int_hard%get_n_in () allocate (mask_in (n_in)) mask_in = kin%sf_chain%get_out_mask () call setup_isolated (term%isolated, core, model, mask_in, term%config%col) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) mask_color = pcm_work%is_fixed_order_nlo_events () class default mask_color = .false. end select call setup_connected (term%connected, term%isolated, core, & term%nlo_type, mask_color) contains subroutine setup_isolated (isolated, core, model, mask, color) type(isolated_state_t), intent(inout), target :: isolated class(prc_core_t), intent(in) :: core class(model_data_t), intent(in), target :: model type(quantum_numbers_mask_t), intent(in), dimension(:) :: mask integer, intent(in), dimension(:) :: color select type (core) class is (prc_blha_t) call isolated%matrix%init_identity(isolated%int_eff) isolated%has_matrix = .true. class default call isolated%setup_square_matrix (core, model, mask, color) end select !!! TODO (PS-09-10-20) We should not square the flows !!! if they come from BLHA either call isolated%setup_square_flows (core, model, mask) end subroutine setup_isolated subroutine setup_connected (connected, isolated, core, nlo_type, mask_color) type(connected_state_t), intent(inout), target :: connected type(isolated_state_t), intent(in), target :: isolated class(prc_core_t), intent(in) :: core integer, intent(in) :: nlo_type logical, intent(in) :: mask_color type(quantum_numbers_mask_t), dimension(:), allocatable :: mask call connected%setup_connected_matrix (isolated) if (term%nlo_type == NLO_VIRTUAL .or. (term%nlo_type == NLO_REAL & .and. term%config%i_term_global == term%config%i_sub) & .or. term%nlo_type == NLO_DGLAP) then !!! We do not care about the subtraction matrix elements in !!! connected%matrix, because all entries there are supposed !!! to be squared. To be able to match with flavor quantum numbers, !!! we remove the subtraction quantum entries from the state matrix. allocate (mask (connected%matrix%get_n_tot())) call mask%set_sub (1) call connected%matrix%reduce_state_matrix (mask, keep_order = .true.) end if call term%init_interaction_qn_index (core, connected%matrix, 0, model, & is_polarized = .false.) select type (core) class is (prc_blha_t) call connected%setup_connected_flows & (isolated, mask_color = mask_color) class default call connected%setup_connected_flows (isolated) end select call connected%setup_state_flv (isolated%get_n_out ()) end subroutine setup_connected end subroutine term_instance_setup_event_data @ %def term_instance_setup_event_data @ Color-correlated matrix elements should be obtained from the external BLHA provider. According to the standard, the matrix elements output is a one-dimensional array. For FKS subtraction, we require the matrix $B_{ij}$. BLHA prescribes a mapping $(i, j) \to k$, where $k$ is the index of the matrix element in the output array. It focusses on the off-diagonal entries, i.e. $i \neq j$. The subroutine [[blha_color_c_fill_offdiag]] realizes this mapping. The diagonal entries can simply be obtained as the product of the Born matrix element and either $C_A$ or $C_F$, which is achieved by [[blha_color_c_fill_diag]]. For simple processes, i.e. those with only one color line, it is $B_{ij} = C_F \cdot B$. For those, we keep the possibility of computing color correlations by a multiplication of the Born matrix element with $C_F$. It is triggered by the [[use_internal_color_correlations]] flag and should be used only for testing purposes. However, it is also used for the threshold computation where the process is well-defined and fixed. <>= procedure :: evaluate_color_correlations => & term_instance_evaluate_color_correlations <>= module subroutine term_instance_evaluate_color_correlations (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core end subroutine term_instance_evaluate_color_correlations <>= module subroutine term_instance_evaluate_color_correlations (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core integer :: i_flv_born select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) select type (pcm => term%pcm) type is (pcm_nlo_t) if (debug_on) call msg_debug2 (D_SUBTRACTION, & "term_instance_evaluate_color_correlations: " // & "use_internal_color_correlations:", & pcm%settings%use_internal_color_correlations) if (debug_on) call msg_debug2 (D_SUBTRACTION, "fac_scale", term%get_fac_scale ()) do i_flv_born = 1, pcm%region_data%n_flv_born select case (term%nlo_type) case (NLO_REAL) call transfer_me_array_to_bij (pcm, i_flv_born, & pcm_work%real_sub%sqme_born (i_flv_born), & pcm_work%real_sub%sqme_born_color_c (:, :, i_flv_born)) case (NLO_MISMATCH) call transfer_me_array_to_bij (pcm, i_flv_born, & pcm_work%soft_mismatch%sqme_born (i_flv_born), & pcm_work%soft_mismatch%sqme_born_color_c (:, :, i_flv_born)) case (NLO_VIRTUAL) !!! This is just a copy of the above with a different offset and can for sure be unified call transfer_me_array_to_bij (pcm, i_flv_born, & -one, pcm_work%virtual%sqme_color_c (:, :, i_flv_born)) case (NLO_DGLAP) call transfer_me_array_to_bij (pcm, i_flv_born, & pcm_work%dglap_remnant%sqme_born (i_flv_born), & pcm_work%dglap_remnant%sqme_color_c_extra (:, :, i_flv_born)) end select end do end select end select contains function get_trivial_cf_factors (n_tot, flv, factorization_mode) result (beta_ij) integer, intent(in) :: n_tot, factorization_mode integer, intent(in), dimension(:) :: flv real(default), dimension(n_tot, n_tot) :: beta_ij if (factorization_mode == NO_FACTORIZATION) then beta_ij = get_trivial_cf_factors_default (n_tot, flv) else beta_ij = get_trivial_cf_factors_threshold (n_tot, flv) end if end function get_trivial_cf_factors function get_trivial_cf_factors_default (n_tot, flv) result (beta_ij) integer, intent(in) :: n_tot integer, intent(in), dimension(:) :: flv real(default), dimension(n_tot, n_tot) :: beta_ij integer :: i, j beta_ij = zero if (count (is_quark (flv)) == 2) then do i = 1, n_tot do j = 1, n_tot if (is_quark(flv(i)) .and. is_quark(flv(j))) then if (i == j) then beta_ij(i,j)= -cf else beta_ij(i,j) = cf end if end if end do end do end if end function get_trivial_cf_factors_default function get_trivial_cf_factors_threshold (n_tot, flv) result (beta_ij) integer, intent(in) :: n_tot integer, intent(in), dimension(:) :: flv real(default), dimension(n_tot, n_tot) :: beta_ij integer :: i beta_ij = zero do i = 1, 4 beta_ij(i,i) = -cf end do beta_ij(1,2) = cf; beta_ij(2,1) = cf beta_ij(3,4) = cf; beta_ij(4,3) = cf end function get_trivial_cf_factors_threshold subroutine transfer_me_array_to_bij (pcm, i_flv, & sqme_born, sqme_color_c) type(pcm_nlo_t), intent(in) :: pcm integer, intent(in) :: i_flv real(default), intent(in) :: sqme_born real(default), dimension(:,:), intent(inout) :: sqme_color_c logical :: special_case_interferences integer :: i_color_c, i_sub, n_offset, i_qn real(default), dimension(:), allocatable :: sqme real(default) :: sqme_born_c if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "transfer_me_array_to_bij") if (pcm%settings%use_internal_color_correlations) then !!! A negative value for sqme_born indicates that the Born matrix !!! element is multiplied at a different place, e.g. in the case !!! of the virtual component sqme_color_c = get_trivial_cf_factors & (pcm%region_data%get_n_legs_born (), & pcm%region_data%get_flv_states_born (i_flv), & pcm%settings%factorization_mode) if (sqme_born > zero) then sqme_color_c = sqme_born * sqme_color_c else if (sqme_born == zero) then sqme_color_c = zero end if else special_case_interferences = & pcm%region_data%nlo_correction_type == "EW" n_offset = 0 if (term%nlo_type == NLO_VIRTUAL) then n_offset = 1 else if (pcm%has_pdfs .and. (term%is_subtraction () & .or. term%nlo_type == NLO_DGLAP)) then n_offset = n_beams_rescaled end if allocate (sqme (term%get_n_sub_color ()), source = zero) do i_sub = 1, term%get_n_sub_color () i_qn = term%connected%trace%get_qn_index (i_flv, i_sub = i_sub + n_offset) if (term%passed_array(i_flv) .or. .not. term%passed) then sqme(i_sub) = real(term%connected%trace%get_matrix_element (i_qn), default) else sqme(i_sub) = zero end if end do call blha_color_c_fill_offdiag (pcm%region_data%n_legs_born, & sqme, sqme_color_c) i_qn = term%connected%trace%get_qn_index (i_flv, i_sub = 0) if (term%passed_array(i_flv) .or. .not. term%passed) then sqme_born_c = real(term%connected%trace%get_matrix_element (i_qn), default) else sqme_born_c = zero end if call blha_color_c_fill_diag (sqme_born_c, & pcm%region_data%get_flv_states_born (i_flv), & sqme_color_c, special_case_interferences) end if end subroutine transfer_me_array_to_bij end subroutine term_instance_evaluate_color_correlations @ %def term_instance_evaluate_color_correlations @ <>= procedure :: evaluate_charge_correlations => & term_instance_evaluate_charge_correlations <>= module subroutine term_instance_evaluate_charge_correlations (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core end subroutine term_instance_evaluate_charge_correlations <>= module subroutine term_instance_evaluate_charge_correlations (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core integer :: i_flv_born select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) select type (pcm => term%pcm) type is (pcm_nlo_t) do i_flv_born = 1, pcm%region_data%n_flv_born select case (term%nlo_type) case (NLO_REAL) call transfer_me_array_to_bij (pcm, i_flv_born, & pcm_work%real_sub%sqme_born (i_flv_born), & pcm_work%real_sub%sqme_born_charge_c (:, :, i_flv_born)) case (NLO_MISMATCH) call transfer_me_array_to_bij (pcm, i_flv_born, & pcm_work%soft_mismatch%sqme_born (i_flv_born), & pcm_work%soft_mismatch%sqme_born_charge_c (:, :, i_flv_born)) case (NLO_VIRTUAL) call transfer_me_array_to_bij (pcm, i_flv_born, & one, pcm_work%virtual%sqme_charge_c (:, :, i_flv_born)) end select end do end select end select contains subroutine transfer_me_array_to_bij (pcm, i_flv, sqme_born, sqme_charge_c) type(pcm_nlo_t), intent(in) :: pcm integer, intent(in) :: i_flv real(default), intent(in) :: sqme_born real(default), dimension(:,:), intent(inout) :: sqme_charge_c integer :: n_legs_born, i, j real(default), dimension(:), allocatable :: sigma real(default), dimension(:), allocatable :: Q n_legs_born = pcm%region_data%n_legs_born associate (flv_born => pcm%region_data%flv_born(i_flv)) allocate (sigma (n_legs_born), Q (size (flv_born%charge))) Q = flv_born%charge sigma(1:flv_born%n_in) = -one sigma(flv_born%n_in + 1: ) = one end associate do i = 1, n_legs_born do j = 1, n_legs_born sqme_charge_c(i, j) = sigma(i) * sigma(j) * Q(i) * Q(j) * (-one) end do end do sqme_charge_c = sqme_charge_c * sqme_born end subroutine transfer_me_array_to_bij end subroutine term_instance_evaluate_charge_correlations @ %def term_instance_evaluate_charge_correlations @ The information about spin correlations is not stored in the [[nlo_settings]] because it is only available after the [[fks_regions]] have been created. <>= procedure :: evaluate_spin_correlations => & term_instance_evaluate_spin_correlations <>= module subroutine term_instance_evaluate_spin_correlations (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core end subroutine term_instance_evaluate_spin_correlations <>= module subroutine term_instance_evaluate_spin_correlations (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core integer :: i_flv, i_sub, i_emitter, emitter, i_qn integer :: n_flv, n_sub_color, n_sub_spin, n_offset,i,j real(default), dimension(1:3, 1:3) :: sqme_spin_c real(default), dimension(:), allocatable :: sqme_spin_c_all real(default), dimension(:), allocatable :: sqme_spin_c_arr if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, & "term_instance_evaluate_spin_correlations") select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) if (pcm_work%real_sub%requires_spin_correlations () & .and. term%nlo_type == NLO_REAL) then select type (core) type is (prc_openloops_t) select type (pcm => term%pcm) type is (pcm_nlo_t) n_flv = term%connected%trace%get_qn_index_n_flv () n_sub_color = term%get_n_sub_color () n_sub_spin = term%get_n_sub_spin () n_offset = 0; if(pcm%has_pdfs) n_offset = n_beams_rescaled allocate (sqme_spin_c_arr(6)) do i_flv = 1, n_flv allocate (sqme_spin_c_all(n_sub_spin)) do i_sub = 1, n_sub_spin i_qn = term%connected%trace%get_qn_index (i_flv, & i_sub = i_sub + n_offset + n_sub_color) if (term%passed_array(i_flv) .or. .not. term%passed) then sqme_spin_c_all(i_sub) = & real(term%connected%trace%get_matrix_element (i_qn), default) else sqme_spin_c_all(i_sub) = zero end if end do do i_emitter = 1, pcm%region_data%n_emitters emitter = pcm%region_data%emitters(i_emitter) if (emitter > 0) then call split_array (sqme_spin_c_all, sqme_spin_c_arr) do j = 1, size (sqme_spin_c, dim=2) do i = j, size (sqme_spin_c, dim=1) !!! Restoring the symmetric matrix packed into a 1-dim array !!! c.f. [[prc_openloops_compute_sqme_spin_c]] sqme_spin_c(i,j) = sqme_spin_c_arr(j + i * (i - 1) / 2) if (i /= j) sqme_spin_c(j,i) = sqme_spin_c(i,j) end do end do pcm_work%real_sub%sqme_born_spin_c(:,:,emitter,i_flv) = sqme_spin_c end if end do deallocate (sqme_spin_c_all) end do end select class default call msg_fatal & ("Spin correlations so far only supported by OpenLoops.") end select end if end select end subroutine term_instance_evaluate_spin_correlations @ %def term_instance_evaluate_spin_correlations @ <>= procedure :: apply_fks => term_instance_apply_fks <>= module subroutine term_instance_apply_fks & (term, kin, alpha_s_sub, alpha_qed_sub) class(term_instance_t), intent(inout) :: term class(kinematics_t), intent(inout) :: kin real(default), intent(in) :: alpha_s_sub, alpha_qed_sub end subroutine term_instance_apply_fks <>= module subroutine term_instance_apply_fks & (term, kin, alpha_s_sub, alpha_qed_sub) class(term_instance_t), intent(inout) :: term class(kinematics_t), intent(inout) :: kin real(default), intent(in) :: alpha_s_sub, alpha_qed_sub real(default), dimension(:), allocatable :: sqme integer :: i, i_phs, emitter, i_qn logical :: is_subtraction select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) select type (pcm => term%pcm) type is (pcm_nlo_t) if (term%connected%has_matrix) then allocate (sqme (pcm%get_n_alr ())) else allocate (sqme (1)) end if sqme = zero select type (phs => kin%phs) type is (phs_fks_t) if (pcm%has_pdfs .and. & pcm%settings%use_internal_color_correlations) then call msg_fatal ("Color correlations for proton processes " // & "so far only supported by OpenLoops.") end if call pcm_work%set_real_and_isr_kinematics & (phs%phs_identifiers, kin%phs%get_sqrts ()) if (kin%emitter < 0) then call pcm_work%set_subtraction_event () do i_phs = 1, pcm%region_data%n_phs emitter = phs%phs_identifiers(i_phs)%emitter call pcm_work%real_sub%compute (emitter, & i_phs, alpha_s_sub, alpha_qed_sub, term%connected%has_matrix, sqme) end do else call pcm_work%set_radiation_event () emitter = kin%emitter; i_phs = kin%i_phs do i = 1, term%connected%trace%get_qn_index_n_flv () i_qn = term%connected%trace%get_qn_index (i) if (term%passed_array(i) .or. .not. term%passed) then pcm_work%real_sub%sqme_real_non_sub (i, i_phs) = & real (term%connected%trace%get_matrix_element (i_qn)) else pcm_work%real_sub%sqme_real_non_sub (i, i_phs) = zero end if end do call pcm_work%real_sub%compute (emitter, i_phs, alpha_s_sub, & alpha_qed_sub, term%connected%has_matrix, sqme) end if end select end select end select if (term%connected%has_trace) & call term%connected%trace%set_only_matrix_element & (1, cmplx (sum(sqme), 0, default)) select type (pcm => term%pcm) type is (pcm_nlo_t) is_subtraction = kin%emitter < 0 if (term%connected%has_matrix) & call refill_evaluator (cmplx (sqme * term%weight, 0, default), & pcm%get_qn (is_subtraction), & pcm%region_data%get_flavor_indices (is_subtraction), & term%connected%matrix) if (term%connected%has_flows) & call refill_evaluator (cmplx (sqme * term%weight, 0, default), & pcm%get_qn (is_subtraction), & pcm%region_data%get_flavor_indices (is_subtraction), & term%connected%flows) end select end subroutine term_instance_apply_fks @ %def term_instance_apply_fks @ <>= procedure :: evaluate_sqme_virt => term_instance_evaluate_sqme_virt <>= module subroutine term_instance_evaluate_sqme_virt & (term, alpha_s, alpha_qed) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: alpha_s, alpha_qed end subroutine term_instance_evaluate_sqme_virt <>= module subroutine term_instance_evaluate_sqme_virt (term, alpha_s, alpha_qed) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: alpha_s, alpha_qed real(default), dimension(2) :: alpha_coupling type(vector4_t), dimension(:), allocatable :: p_born real(default), dimension(:), allocatable :: sqme_virt integer :: i_flv, i_qn_born, i_qn_virt if (term%nlo_type /= NLO_VIRTUAL) call msg_fatal ("Trying to " // & "evaluate virtual matrix element with unsuited term_instance.") if (debug2_active (D_VIRTUAL)) then call msg_debug2 & (D_VIRTUAL, "Evaluating virtual-subtracted matrix elements") print *, 'ren_scale: ', term%get_ren_scale () print *, 'fac_scale: ', term%get_fac_scale () if (allocated (term%es_scale)) then print *, 'ES scale: ', term%es_scale else print *, 'ES scale: ', term%get_ren_scale () end if end if select type (pcm => term%pcm) type is (pcm_nlo_t) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) alpha_coupling = [alpha_s, alpha_qed] if (debug2_active (D_VIRTUAL)) then print *, 'alpha_s: ', alpha_coupling (1) print *, 'alpha_qed: ', alpha_coupling (2) end if allocate (p_born (pcm%region_data%n_legs_born)) if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) then p_born = pcm_work%real_kinematics%p_born_onshell%get_momenta(1) else p_born = term%int_hard%get_momenta () end if call pcm_work%set_momenta_and_scales_virtual & (p_born, term%ren_scale, term%get_fac_scale (), & term%es_scale) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) associate (virtual => pcm_work%virtual) do i_flv = 1, term%connected%trace%get_qn_index_n_flv () i_qn_born = term%connected%trace%get_qn_index (i_flv, i_sub = 0) i_qn_virt = term%connected%trace%get_qn_index (i_flv, i_sub = 1) if (term%passed_array(i_flv) .or. .not. term%passed) then virtual%sqme_born(i_flv) = & real (term%connected%trace%get_matrix_element (i_qn_born)) virtual%sqme_virt_fin(i_flv) = & real (term%connected%trace%get_matrix_element (i_qn_virt)) else virtual%sqme_born(i_flv) = zero virtual%sqme_virt_fin(i_flv) = zero end if end do end associate end select call pcm_work%compute_sqme_virt (term%pcm, term%p_hard, & alpha_coupling, term%connected%has_matrix, sqme_virt) call term%connected%trace%set_only_matrix_element & (1, cmplx (sum(sqme_virt), 0, default)) if (term%connected%has_matrix) & call refill_evaluator (cmplx (sqme_virt * term%weight, & 0, default), pcm%get_qn (.true.), & remove_duplicates_from_int_array ( & pcm%region_data%get_flavor_indices (.true.)), & term%connected%matrix) if (term%connected%has_flows) & call refill_evaluator (cmplx (sqme_virt * term%weight, & 0, default), pcm%get_qn (.true.), & remove_duplicates_from_int_array ( & pcm%region_data%get_flavor_indices (.true.)), & term%connected%flows) end select end select end subroutine term_instance_evaluate_sqme_virt @ %def term_instance_evaluate_sqme_virt @ Needs generalization to electroweak corrections. <>= procedure :: evaluate_sqme_mismatch => term_instance_evaluate_sqme_mismatch <>= module subroutine term_instance_evaluate_sqme_mismatch (term, alpha_s) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: alpha_s end subroutine term_instance_evaluate_sqme_mismatch <>= module subroutine term_instance_evaluate_sqme_mismatch (term, alpha_s) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: alpha_s real(default), dimension(:), allocatable :: sqme_mism if (term%nlo_type /= NLO_MISMATCH) call msg_fatal & ("Trying to evaluate soft mismatch with unsuited term_instance.") select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) call pcm_work%compute_sqme_mismatch & (term%pcm, alpha_s, term%connected%has_matrix, sqme_mism) end select call term%connected%trace%set_only_matrix_element & (1, cmplx (sum (sqme_mism) * term%weight, 0, default)) if (term%connected%has_matrix) then select type (pcm => term%pcm) type is (pcm_nlo_t) if (term%connected%has_matrix) & call refill_evaluator (cmplx (sqme_mism * term%weight, 0, default), & pcm%get_qn (.true.), & remove_duplicates_from_int_array ( & pcm%region_data%get_flavor_indices (.true.)), & term%connected%matrix) if (term%connected%has_flows) & call refill_evaluator (cmplx (sqme_mism * term%weight, 0, default), & pcm%get_qn (.true.), & remove_duplicates_from_int_array ( & pcm%region_data%get_flavor_indices (.true.)), & term%connected%flows) end select end if end subroutine term_instance_evaluate_sqme_mismatch @ %def term_instance_evaluate_sqme_mismatch @ <>= procedure :: evaluate_sqme_dglap => term_instance_evaluate_sqme_dglap <>= module subroutine term_instance_evaluate_sqme_dglap & (term, alpha_s, alpha_qed) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: alpha_s, alpha_qed end subroutine term_instance_evaluate_sqme_dglap <>= module subroutine term_instance_evaluate_sqme_dglap (term, alpha_s, alpha_qed) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: alpha_s, alpha_qed real(default), dimension(2) :: alpha_coupling real(default), dimension(:), allocatable :: sqme_dglap integer :: i_flv if (term%nlo_type /= NLO_DGLAP) call msg_fatal & ("Trying to evaluate DGLAP remnant with unsuited term_instance.") if (debug_on) call msg_debug2 & (D_PROCESS_INTEGRATION, "term_instance_evaluate_sqme_dglap") select type (pcm => term%pcm) type is (pcm_nlo_t) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) alpha_coupling = [alpha_s,alpha_qed] if (debug2_active (D_PROCESS_INTEGRATION)) then associate (n_flv => pcm_work%dglap_remnant%reg_data%n_flv_born) print *, "size(sqme_born) = ", & size (pcm_work%dglap_remnant%sqme_born) call term%connected%trace%write () end associate end if call pcm_work%compute_sqme_dglap_remnant (pcm, alpha_coupling, & term%connected%has_matrix, sqme_dglap) end select end select call term%connected%trace%set_only_matrix_element & (1, cmplx (sum (sqme_dglap) * term%weight, 0, default)) if (term%connected%has_matrix) then select type (pcm => term%pcm) type is (pcm_nlo_t) call refill_evaluator (cmplx (sqme_dglap * term%weight, 0, default), & pcm%get_qn (.true.), & remove_duplicates_from_int_array ( & pcm%region_data%get_flavor_indices (.true.)), & term%connected%matrix) if (term%connected%has_flows) then call refill_evaluator & (cmplx (sqme_dglap * term%weight, 0, default), & pcm%get_qn (.true.), & remove_duplicates_from_int_array ( & pcm%region_data%get_flavor_indices (.true.)), & term%connected%flows) end if end select end if end subroutine term_instance_evaluate_sqme_dglap @ %def term_instance_evaluate_sqme_dglap @ Reset the term instance: clear the parton-state expressions and deactivate. <>= procedure :: reset => term_instance_reset <>= module subroutine term_instance_reset (term) class(term_instance_t), intent(inout) :: term end subroutine term_instance_reset <>= module subroutine term_instance_reset (term) class(term_instance_t), intent(inout) :: term call term%connected%reset_expressions () if (allocated (term%alpha_qcd_forced)) deallocate (term%alpha_qcd_forced) term%active = .false. end subroutine term_instance_reset @ %def term_instance_reset @ Force an $\alpha_s$ value that should be used in the matrix-element calculation. <>= procedure :: set_alpha_qcd_forced => term_instance_set_alpha_qcd_forced <>= module subroutine term_instance_set_alpha_qcd_forced (term, alpha_qcd) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: alpha_qcd end subroutine term_instance_set_alpha_qcd_forced <>= module subroutine term_instance_set_alpha_qcd_forced (term, alpha_qcd) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: alpha_qcd if (allocated (term%alpha_qcd_forced)) then term%alpha_qcd_forced = alpha_qcd else allocate (term%alpha_qcd_forced, source = alpha_qcd) end if end subroutine term_instance_set_alpha_qcd_forced @ %def term_instance_set_alpha_qcd_forced @ Complete the kinematics computation for the effective parton states. We assume that the [[compute_hard_kinematics]] method of the process component instance has already been called, so the [[int_hard]] contains the correct hard kinematics. The duty of this procedure is first to compute the effective kinematics and store this in the [[int_eff]] effective interaction inside the [[isolated]] parton state. The effective kinematics may differ from the kinematics in the hard interaction. It may involve parton recombination or parton splitting. The [[rearrange_partons]] method is responsible for this part. We may also call a method to compute the effective structure-function chain at this point. This is not implemented yet. In the simple case that no rearrangement is necessary, as indicated by the [[rearrange]] flag, the effective interaction is a pointer to the hard interaction, and we can skip the rearrangement method. Similarly for the effective structure-function chain. The final step of kinematics setup is to transfer the effective kinematics to the evaluators and to the [[subevt]]. <>= procedure :: compute_eff_kinematics => & term_instance_compute_eff_kinematics <>= module subroutine term_instance_compute_eff_kinematics (term) class(term_instance_t), intent(inout) :: term end subroutine term_instance_compute_eff_kinematics <>= module subroutine term_instance_compute_eff_kinematics (term) class(term_instance_t), intent(inout) :: term term%checked = .false. term%passed = .false. call term%isolated%receive_kinematics () call term%connected%receive_kinematics () end subroutine term_instance_compute_eff_kinematics @ %def term_instance_compute_eff_kinematics @ Inverse. Reconstruct the connected state from the momenta in the trace evaluator (which we assume to be set), then reconstruct the isolated state as far as possible. The second part finalizes the momentum configuration, using the incoming seed momenta <>= procedure :: recover_hard_kinematics => & term_instance_recover_hard_kinematics <>= module subroutine term_instance_recover_hard_kinematics (term) class(term_instance_t), intent(inout) :: term end subroutine term_instance_recover_hard_kinematics <>= module subroutine term_instance_recover_hard_kinematics (term) class(term_instance_t), intent(inout) :: term term%checked = .false. term%passed = .false. call term%connected%send_kinematics () call term%isolated%send_kinematics () end subroutine term_instance_recover_hard_kinematics @ %def term_instance_recover_hard_kinematics @ Check the term whether it passes cuts and, if successful, evaluate scales and weights. The factorization scale is also given to the term kinematics, enabling structure-function evaluation. <>= procedure :: evaluate_expressions => & term_instance_evaluate_expressions <>= module subroutine term_instance_evaluate_expressions & (term, config, scale_forced) class(term_instance_t), intent(inout) :: term type(process_beam_config_t), intent(in) :: config real(default), intent(in), allocatable, optional :: scale_forced end subroutine term_instance_evaluate_expressions <>= module subroutine term_instance_evaluate_expressions & (term, config, scale_forced) class(term_instance_t), intent(inout) :: term type(process_beam_config_t), intent(in) :: config real(default), intent(in), allocatable, optional :: scale_forced real(default) :: scale = 0 real(default) :: weight = 1 real(default), allocatable :: fac_scale, ren_scale type(interaction_t), pointer :: src_int type(state_matrix_t), pointer :: state_matrix type(flavor_t), dimension(:), allocatable :: flv_int, flv_src, f_in, f_out logical :: passed integer :: n_in, n_vir, n_out, n_tot, n_flv integer :: i, j, k n_flv = term%connected%trace%get_qn_index_n_flv () if (.not. allocated (term%passed_array)) allocate (term%passed_array(n_flv)) if (term%flv_dep_cut_eval) then do k = 1, n_flv if (k == term%i_flv_to_i_flv_rep(k)) then n_in = term%int_hard%get_n_in () associate (int_eff => term%isolated%int_eff) state_matrix => int_eff%get_state_matrix_ptr () n_tot = int_eff%get_n_tot () flv_int = quantum_numbers_get_flavor & (state_matrix%get_quantum_number (k)) allocate (f_in (n_in)) f_in = flv_int(1:n_in) deallocate (flv_int) end associate n_in = term%connected%trace%get_n_in () n_vir = term%connected%trace%get_n_vir () n_out = term%connected%trace%get_n_out () allocate (f_out (n_out)) do j = 1, n_out call term%connected%trace%find_source & (n_in + n_vir + j, src_int, i) if (associated (src_int)) then state_matrix => src_int%get_state_matrix_ptr () flv_src = quantum_numbers_get_flavor & (state_matrix%get_quantum_number (k)) f_out(j) = flv_src(i) deallocate (flv_src) end if end do call term%connected%renew_flv_content_subevt & (term%isolated%sf_chain_eff, & config%data%flv, f_in, f_out) call term%connected%evaluate_expressions (passed, & scale, fac_scale, ren_scale, weight, & scale_forced, force_evaluation = .true.) if (k == 1) then term%scale = scale if (allocated (fac_scale)) then if (.not. allocated (term%fac_scale)) then allocate (term%fac_scale, source = fac_scale) else term%fac_scale = fac_scale end if end if if (allocated (ren_scale)) then if (.not. allocated (term%ren_scale)) then allocate (term%ren_scale, source = ren_scale) else term%ren_scale = ren_scale end if end if term%weight = weight end if term%passed_array(k) = passed deallocate (f_in) deallocate (f_out) else term%passed_array(k) = term%passed_array(term%i_flv_to_i_flv_rep(k)) end if end do term%passed = any (term%passed_array) else call term%connected%evaluate_expressions (term%passed, & term%scale, term%fac_scale, term%ren_scale, term%weight, & scale_forced, force_evaluation = .true.) term%passed_array = term%passed end if term%checked = .true. end subroutine term_instance_evaluate_expressions @ %def term_instance_evaluate_expressions @ Evaluate the trace: first evaluate the hard interaction, then the trace evaluator. We use the [[evaluate_interaction]] method of the process component which generated this term. The [[subevt]] and cut expressions are not yet filled. The [[component]] argument is intent(inout) because the [[compute_amplitude]] method may modify the [[core_state]] workspace object. <>= procedure :: evaluate_interaction => term_instance_evaluate_interaction <>= module subroutine term_instance_evaluate_interaction (term, core, kin) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(in), pointer :: core type(kinematics_t), intent(inout) :: kin end subroutine term_instance_evaluate_interaction <>= module subroutine term_instance_evaluate_interaction (term, core, kin) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(in), pointer :: core type(kinematics_t), intent(inout) :: kin if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, & "term_instance_evaluate_interaction") if (kin%only_cm_frame .and. (.not. kin%lab_is_cm())) then term%p_hard = kin%get_boost_to_cms () * term%int_hard%get_momenta () else term%p_hard = term%int_hard%get_momenta () end if select type (core) class is (prc_external_t) call term%evaluate_interaction_external (core, kin) class default call term%evaluate_interaction_default (core) end select call term%int_hard%set_matrix_element (term%amp) end subroutine term_instance_evaluate_interaction @ %def term_instance_evaluate_interaction @ <>= procedure :: evaluate_interaction_default & => term_instance_evaluate_interaction_default <>= module subroutine term_instance_evaluate_interaction_default (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(in) :: core end subroutine term_instance_evaluate_interaction_default <>= module subroutine term_instance_evaluate_interaction_default (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(in) :: core real(default) :: fac_scale, ren_scale integer :: i if (allocated (term%fac_scale)) then fac_scale = term%fac_scale else fac_scale = term%scale end if if (allocated (term%ren_scale)) then ren_scale = term%ren_scale else ren_scale = term%scale end if do i = 1, term%config%n_allowed term%amp(i) = core%compute_amplitude (term%config%i_term, term%p_hard, & term%config%flv(i), term%config%hel(i), term%config%col(i), & fac_scale, ren_scale, term%alpha_qcd_forced, & term%core_state) end do select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) call pcm_work%set_fac_scale (fac_scale) end select end subroutine term_instance_evaluate_interaction_default @ %def term_instance_evaluate_interaction_default @ <>= procedure :: evaluate_interaction_external & => term_instance_evaluate_interaction_external <>= module subroutine term_instance_evaluate_interaction_external & (term, core, kin) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core type(kinematics_t), intent(inout) :: kin end subroutine term_instance_evaluate_interaction_external <>= module subroutine term_instance_evaluate_interaction_external & (term, core, kin) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core type(kinematics_t), intent(inout) :: kin if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, & "term_instance_evaluate_interaction_external") select type (core_state => term%core_state) type is (openloops_state_t) select type (core) type is (prc_openloops_t) call core%compute_alpha_s (core_state, term%get_ren_scale ()) if (allocated (core_state%threshold_data)) & call evaluate_threshold_parameters (core_state, core, kin%phs%get_sqrts ()) end select class is (prc_external_state_t) select type (core) class is (prc_external_t) call core%compute_alpha_s (core_state, term%get_ren_scale ()) end select end select call evaluate_threshold_interaction () if (term%nlo_type == NLO_VIRTUAL) then call term%evaluate_interaction_external_loop (core) else call term%evaluate_interaction_external_tree (core) end if select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) call pcm_work%set_fac_scale (term%get_fac_scale ()) end select contains subroutine evaluate_threshold_parameters (core_state, core, sqrts) type(openloops_state_t), intent(inout) :: core_state type(prc_openloops_t), intent(inout) :: core real(default), intent(in) :: sqrts real(default) :: mtop, wtop mtop = m1s_to_mpole (sqrts) wtop = core_state%threshold_data%compute_top_width & (mtop, core_state%alpha_qcd) call core%set_mass_and_width (6, mtop, wtop) end subroutine subroutine evaluate_threshold_interaction () integer :: leg select type (core) type is (prc_threshold_t) if (term%nlo_type > BORN) then select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) if (kin%emitter >= 0) then call core%set_offshell_momenta & (pcm_work%real_kinematics%p_real_cms%get_momenta(term%config%i_term)) leg = thr_leg (kin%emitter) call core%set_leg (leg) call core%set_onshell_momenta & (pcm_work%real_kinematics%p_real_onshell(leg)%get_momenta(term%config%i_term)) else call core%set_leg (0) call core%set_offshell_momenta & (pcm_work%real_kinematics%p_born_cms%get_momenta(1)) end if end select else call core%set_leg (-1) call core%set_offshell_momenta (term%p_hard) end if end select end subroutine evaluate_threshold_interaction end subroutine term_instance_evaluate_interaction_external @ %def term_instance_evaluate_interaction_external @ Retrieve the matrix elements from a matrix element provider and place them into [[term%amp]]. For the handling of NLO calculations, FKS applies a book keeping handling flavor and/or particle type (e.g. for QCD: quark/gluon and quark flavor) in order to calculate the subtraction terms. Therefore, we have to insert the calculated matrix elements correctly into the state matrix where each entry corresponds to a set of quantum numbers. We apply a mapping [[hard_qn_ind]] from a list of quantum numbers provided by FKS to the hard process [[int_hard]]. The calculated matrix elements are insert into [[term%amp]] in the following way. The first [[n_born]] particles are the matrix element of the hard process. In non-trivial beams, we store another [[n_beams_rescaled]] copies of these matrix elements as the first [[n_beams_rescaled]] subtractions. This is a remnant from times before the method [[term_instance_set_sf_factors]] and these entries are not used anymore. However, eliminating these entries involves deeper changes in how the connection tables for the evaluator product are set up and should therefore be part of a larger refactoring of the interactions \& state matrices. The next $n_{\text{born}}\times n_{sub_color}$ are color-correlated Born matrix elements, with then again the next $n_{\text{born}}\times n_{emitters}\times n_{sub_spin}$ being spin-correlated Born matrix elements. If two or more flavor structures would produce the same amplitude we only compute one and use the [[eqv_index]] determined by the [[prc_core]] and just copy the result to improve performance. <>= procedure :: evaluate_interaction_external_tree & => term_instance_evaluate_interaction_external_tree <>= module subroutine term_instance_evaluate_interaction_external_tree & (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core end subroutine term_instance_evaluate_interaction_external_tree <>= module subroutine term_instance_evaluate_interaction_external_tree & (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core real(default) :: sqme real(default), dimension(:), allocatable :: sqme_color_c real(default), dimension(:), allocatable :: sqme_spin_c real(default), dimension(6) :: sqme_spin_c_tmp integer :: n_flv, n_hel, n_sub_color, n_sub_spin, n_pdf_off integer :: i_flv, i_hel, i_sub, i_color_c, i_color_c_eqv, & i_spin_c, i_spin_c_eqv integer :: i_flv_eqv, i_hel_eqv integer :: emitter, i_emitter logical :: bad_point, bp logical, dimension(:,:), allocatable :: eqv_me_evaluated if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, & "term_instance_evaluate_interaction_external_tree") allocate (sqme_color_c (blha_result_array_size & (term%int_hard%get_n_tot (), BLHA_AMP_COLOR_C))) n_flv = term%int_hard%get_qn_index_n_flv () n_hel = term%int_hard%get_qn_index_n_hel () n_sub_color = term%get_n_sub_color () n_sub_spin = term%get_n_sub_spin () allocate (eqv_me_evaluated(n_flv,n_hel)) eqv_me_evaluated = .false. do i_flv = 1, n_flv if (.not. term%passed_array(i_flv) .and. term%passed) cycle do i_hel = 1, n_hel i_flv_eqv = core%data%eqv_flv_index(i_flv) i_hel_eqv = core%data%eqv_hel_index(i_hel) if (.not. eqv_me_evaluated(i_flv_eqv, i_hel_eqv)) then select type (core) class is (prc_external_t) call core%update_alpha_s (term%core_state, term%get_ren_scale ()) call core%compute_sqme (i_flv, i_hel, term%p_hard, & term%get_ren_scale (), sqme, bad_point) call term%pcm_work%set_bad_point (bad_point) associate (i_int => term%int_hard%get_qn_index & (i_flv = i_flv, i_hel = i_hel, i_sub = 0)) term%amp(i_int) = cmplx (sqme, 0, default) end associate end select n_pdf_off = 0 if (term%pcm%has_pdfs .and. & (term%is_subtraction () .or. term%nlo_type == NLO_DGLAP)) then n_pdf_off = n_pdf_off + n_beams_rescaled do i_sub = 1, n_pdf_off term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub)) = & term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub = 0)) end do end if if (term%pcm%has_pdfs .and. term%nlo_type == NLO_DGLAP) then sqme_color_c = zero select type (pcm => term%pcm) type is (pcm_nlo_t) if (pcm%settings%nlo_correction_type == "EW" .and. & pcm%region_data%alphas_power > 0) then select type (core) class is (prc_blha_t) call core%compute_sqme_color_c_raw (i_flv, i_hel, & term%p_hard, term%get_ren_scale (), sqme_color_c, & bad_point) call term%pcm_work%set_bad_point (bad_point) class is (prc_recola_t) call core%compute_sqme_color_c_raw (i_flv, i_hel, & term%p_hard, term%get_ren_scale (), sqme_color_c, & bad_point) call term%pcm_work%set_bad_point (bad_point) end select end if end select do i_sub = 1, n_sub_color i_color_c = term%int_hard%get_qn_index & (i_flv, i_hel, i_sub + n_pdf_off) term%amp(i_color_c) = cmplx (sqme_color_c(i_sub), 0, default) end do end if if ((term%nlo_type == NLO_REAL .and. term%is_subtraction ()) .or. & term%nlo_type == NLO_MISMATCH) then sqme_color_c = zero select type (core) class is (prc_blha_t) call core%compute_sqme_color_c_raw (i_flv, i_hel, & term%p_hard, term%get_ren_scale (), sqme_color_c, bad_point) call term%pcm_work%set_bad_point (bad_point) class is (prc_recola_t) call core%compute_sqme_color_c_raw (i_flv, i_hel, & term%p_hard, term%get_ren_scale (), sqme_color_c, bad_point) call term%pcm_work%set_bad_point (bad_point) end select do i_sub = 1, n_sub_color i_color_c = term%int_hard%get_qn_index & (i_flv, i_hel, i_sub + n_pdf_off) term%amp(i_color_c) = cmplx (sqme_color_c(i_sub), 0, default) end do if (n_sub_spin > 0) then bad_point = .false. allocate (sqme_spin_c(0)) select type (core) type is (prc_openloops_t) select type (pcm => term%pcm) type is (pcm_nlo_t) do i_emitter = 1, pcm%region_data%n_emitters emitter = pcm%region_data%emitters(i_emitter) if (emitter > 0) then call core%compute_sqme_spin_c & (i_flv, & i_hel, & emitter, & term%p_hard, & term%get_ren_scale (), & sqme_spin_c_tmp, & bp) sqme_spin_c = [sqme_spin_c, sqme_spin_c_tmp] bad_point = bad_point .or. bp end if end do end select do i_sub = 1, n_sub_spin i_spin_c = term%int_hard%get_qn_index (i_flv, i_hel, & i_sub + n_pdf_off + n_sub_color) term%amp(i_spin_c) = cmplx & (sqme_spin_c(i_sub), 0, default) end do end select deallocate (sqme_spin_c) end if end if eqv_me_evaluated(i_flv_eqv, i_hel_eqv) = .true. else associate (i_int => term%int_hard%get_qn_index & (i_flv = i_flv, i_hel = i_hel, i_sub = 0), & i_int_eqv => term%int_hard%get_qn_index & (i_flv = i_flv_eqv, i_hel = i_hel_eqv, i_sub = 0)) term%amp(i_int) = term%amp(i_int_eqv) end associate n_pdf_off = 0 if (term%pcm%has_pdfs .and. & (term%is_subtraction () .or. term%nlo_type == NLO_DGLAP)) then n_pdf_off = n_pdf_off + n_beams_rescaled do i_sub = 1, n_pdf_off term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub)) = & term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub = 0)) end do end if if (term%pcm%has_pdfs .and. term%nlo_type == NLO_DGLAP) then do i_sub = 1, n_sub_color i_color_c = term%int_hard%get_qn_index & (i_flv, i_hel, i_sub + n_pdf_off) i_color_c_eqv = term%int_hard%get_qn_index & (i_flv_eqv, i_hel_eqv, i_sub + n_pdf_off) term%amp(i_color_c) = term%amp(i_color_c_eqv) end do end if if ((term%nlo_type == NLO_REAL .and. term%is_subtraction ()) .or. & term%nlo_type == NLO_MISMATCH) then do i_sub = 1, n_sub_color i_color_c = term%int_hard%get_qn_index & (i_flv, i_hel, i_sub + n_pdf_off) i_color_c_eqv = term%int_hard%get_qn_index & (i_flv_eqv, i_hel_eqv, i_sub + n_pdf_off) term%amp(i_color_c) = term%amp(i_color_c_eqv) end do do i_sub = 1, n_sub_spin i_spin_c = term%int_hard%get_qn_index (i_flv, i_hel, & i_sub + n_pdf_off + n_sub_color) i_spin_c_eqv = term%int_hard%get_qn_index (i_flv_eqv, i_hel_eqv, & i_sub + n_pdf_off + n_sub_color) term%amp(i_spin_c) = term%amp(i_spin_c_eqv) end do end if end if end do end do end subroutine term_instance_evaluate_interaction_external_tree @ %def term_instance_evaluate_interaction_external_tree @ Same as for [[term_instance_evaluate_interaction_external_tree]], but for the integrated-subtraction and finite one-loop terms. We only need color-correlated Born matrix elements, but an additional entry per flavor structure for the finite one-loop contribution. We thus have $2+n_{sub_color}$ entries in the [[term%amp]] for each [[i_flv]] and [[i_hel]] combination. If two or more flavor structures would produce the same amplitude we only compute one and use the [[eqv_index]] determined by the [[prc_core]] and just copy the result to improve performance. <>= procedure :: evaluate_interaction_external_loop & => term_instance_evaluate_interaction_external_loop <>= module subroutine term_instance_evaluate_interaction_external_loop & (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(in) :: core end subroutine term_instance_evaluate_interaction_external_loop <>= module subroutine term_instance_evaluate_interaction_external_loop & (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(in) :: core integer :: n_hel, n_sub, n_flv integer :: i, i_flv, i_hel, i_sub, i_virt, i_color_c, i_color_c_eqv integer :: i_flv_eqv, i_hel_eqv real(default), dimension(4) :: sqme_virt real(default), dimension(:), allocatable :: sqme_color_c real(default) :: es_scale logical :: bad_point logical, dimension(:,:), allocatable :: eqv_me_evaluated if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, & "term_instance_evaluate_interaction_external_loop") allocate (sqme_color_c (blha_result_array_size & (term%int_hard%get_n_tot (), BLHA_AMP_COLOR_C))) n_flv = term%int_hard%get_qn_index_n_flv () n_hel = term%int_hard%get_qn_index_n_hel () n_sub = term%int_hard%get_qn_index_n_sub () allocate (eqv_me_evaluated(n_flv,n_hel)) eqv_me_evaluated = .false. i_virt = 1 do i_flv = 1, n_flv if (.not. term%passed_array(i_flv) .and. term%passed) cycle do i_hel = 1, n_hel i_flv_eqv = core%data%eqv_flv_index(i_flv) i_hel_eqv = core%data%eqv_hel_index(i_hel) if (.not. eqv_me_evaluated(i_flv_eqv, i_hel_eqv)) then select type (core) class is (prc_external_t) if (allocated (term%es_scale)) then es_scale = term%es_scale else es_scale = term%get_ren_scale () end if call core%compute_sqme_virt (i_flv, i_hel, term%p_hard, & term%get_ren_scale (), es_scale, & term%pcm%blha_defaults%loop_method, & sqme_virt, bad_point) call term%pcm_work%set_bad_point (bad_point) end select associate (i_born => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = 0), & i_loop => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = i_virt)) term%amp(i_loop) = cmplx (sqme_virt(3), 0, default) term%amp(i_born) = cmplx (sqme_virt(4), 0, default) end associate select type (pcm => term%pcm) type is (pcm_nlo_t) select type (core) class is (prc_blha_t) call core%compute_sqme_color_c_raw (i_flv, i_hel, & term%p_hard, term%get_ren_scale (), & sqme_color_c, bad_point) call term%pcm_work%set_bad_point (bad_point) do i_sub = 1 + i_virt, n_sub i_color_c = term%int_hard%get_qn_index & (i_flv, i_hel = i_hel, i_sub = i_sub) ! Index shift: i_sub - i_virt term%amp(i_color_c) = & cmplx (sqme_color_c(i_sub - i_virt), 0, default) end do type is (prc_recola_t) call core%compute_sqme_color_c_raw (i_flv, i_hel, & term%p_hard, term%get_ren_scale (), sqme_color_c, bad_point) call term%pcm_work%set_bad_point (bad_point) do i_sub = 1 + i_virt, n_sub i_color_c = term%int_hard%get_qn_index & (i_flv, i_hel = i_hel, i_sub = i_sub) ! Index shift: i_sub - i_virt term%amp(i_color_c) = & cmplx (sqme_color_c(i_sub - i_virt), 0, default) end do end select end select eqv_me_evaluated(i_flv_eqv, i_hel_eqv) = .true. else associate (i_born => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = 0), & i_loop => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = i_virt), & i_born_eqv => term%int_hard%get_qn_index & (i_flv_eqv, i_hel = i_hel_eqv, i_sub = 0), & i_loop_eqv => term%int_hard%get_qn_index & (i_flv_eqv, i_hel = i_hel_eqv, i_sub = 1)) term%amp(i_loop) = term%amp(i_loop_eqv) term%amp(i_born) = term%amp(i_born_eqv) end associate do i_sub = 1 + i_virt, n_sub i_color_c = term%int_hard%get_qn_index & (i_flv, i_hel = i_hel, i_sub = i_sub) i_color_c_eqv = term%int_hard%get_qn_index & (i_flv_eqv, i_hel = i_hel_eqv, i_sub = i_sub) ! Index shift: i_sub - i_virt term%amp(i_color_c) = term%amp(i_color_c_eqv) end do end if end do end do end subroutine term_instance_evaluate_interaction_external_loop @ %def term_instance_evaluate_interaction_external_loop @ Evaluate the trace. First evaluate the structure-function chain (i.e., the density matrix of the incoming partons). Do this twice, in case the sf-chain instances within [[kin]] and [[isolated]] differ. Next, evaluate the hard interaction, then compute the convolution with the initial state. <>= procedure :: evaluate_trace => term_instance_evaluate_trace <>= module subroutine term_instance_evaluate_trace (term, kin) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin end subroutine term_instance_evaluate_trace <>= module subroutine term_instance_evaluate_trace (term, kin) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin real(default) :: fac_scale if (allocated (term%fac_scale)) then fac_scale = term%fac_scale else fac_scale = term%scale end if call kin%evaluate_sf_chain (fac_scale, term%negative_sf) call term%evaluate_scaled_sf_chains (kin) call term%isolated%evaluate_sf_chain (fac_scale) call term%isolated%evaluate_trace () call term%connected%evaluate_trace () end subroutine term_instance_evaluate_trace @ %def term_instance_evaluate_trace @ Include rescaled structure functions due to NLO calculation. We rescale the structure function for the real subtraction [[sf_rescale_collinear]], the collinear counter terms [[sf_rescale_dglap_t]] and for the case, in which we have an emitter in the initial state, we rescale the kinematics for it using [[sf_rescale_real_t]]. The references are arXiv:0709.2092, Eqs.~(2.35)-(2.42). Obviously, it is completely irrelevant, which beam is treated. It becomes problematic when handling $ep$ collisions. Gfortran 7/8/9 bug, has to remain in the main module: <>= procedure :: evaluate_scaled_sf_chains => & term_instance_evaluate_scaled_sf_chains <>= subroutine term_instance_evaluate_scaled_sf_chains (term, kin) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin class(sf_rescale_t), allocatable :: sf_rescale if (.not. term%pcm%has_pdfs) return if (term%nlo_type == NLO_REAL) then if (term%is_subtraction ()) then allocate (sf_rescale_collinear_t :: sf_rescale) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) select type (sf_rescale) type is (sf_rescale_collinear_t) call sf_rescale%set (pcm_work%real_kinematics%xi_tilde) end select end select call kin%sf_chain%evaluate (term%get_fac_scale (), & term%negative_sf, sf_rescale) deallocate (sf_rescale) else if (kin%emitter >= 0 .and. kin%emitter <= kin%n_in) then allocate (sf_rescale_real_t :: sf_rescale) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) select type (sf_rescale) type is (sf_rescale_real_t) call sf_rescale%set (pcm_work%real_kinematics%xi_tilde * & pcm_work%real_kinematics%xi_max (kin%i_phs), & pcm_work%real_kinematics%y (kin%i_phs)) end select end select call kin%sf_chain%evaluate (term%get_fac_scale (), & term%negative_sf, sf_rescale) deallocate (sf_rescale) else call kin%sf_chain%evaluate (term%get_fac_scale (), term%negative_sf) end if else if (term%nlo_type == NLO_DGLAP) then allocate (sf_rescale_dglap_t :: sf_rescale) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) select type (sf_rescale) type is (sf_rescale_dglap_t) call sf_rescale%set (pcm_work%isr_kinematics%z) end select end select call kin%sf_chain%evaluate (term%get_fac_scale (), & term%negative_sf, sf_rescale) deallocate (sf_rescale) end if end subroutine term_instance_evaluate_scaled_sf_chains @ %def term_instance_evaluate_scaled_sf_chains @ Evaluate the extra data that we need for processing the object as a physical event. <>= procedure :: evaluate_event_data => term_instance_evaluate_event_data <>= module subroutine term_instance_evaluate_event_data (term) class(term_instance_t), intent(inout) :: term end subroutine term_instance_evaluate_event_data <>= module subroutine term_instance_evaluate_event_data (term) class(term_instance_t), intent(inout) :: term logical :: only_momenta only_momenta = term%nlo_type > BORN call term%isolated%evaluate_event_data (only_momenta) call term%connected%evaluate_event_data (only_momenta) end subroutine term_instance_evaluate_event_data @ %def term_instance_evaluate_event_data @ <>= procedure :: set_fac_scale => term_instance_set_fac_scale <>= module subroutine term_instance_set_fac_scale (term, fac_scale) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: fac_scale end subroutine term_instance_set_fac_scale <>= module subroutine term_instance_set_fac_scale (term, fac_scale) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: fac_scale term%fac_scale = fac_scale end subroutine term_instance_set_fac_scale @ %def term_instance_set_fac_scale @ Return data that might be useful for external processing. The factorization scale and renormalization scale are identical to the general scale if not explicitly set: <>= procedure :: get_fac_scale => term_instance_get_fac_scale procedure :: get_ren_scale => term_instance_get_ren_scale <>= module function term_instance_get_fac_scale (term) result (fac_scale) class(term_instance_t), intent(in) :: term real(default) :: fac_scale end function term_instance_get_fac_scale module function term_instance_get_ren_scale (term) result (ren_scale) class(term_instance_t), intent(in) :: term real(default) :: ren_scale end function term_instance_get_ren_scale <>= module function term_instance_get_fac_scale (term) result (fac_scale) class(term_instance_t), intent(in) :: term real(default) :: fac_scale if (allocated (term%fac_scale)) then fac_scale = term%fac_scale else fac_scale = term%scale end if end function term_instance_get_fac_scale module function term_instance_get_ren_scale (term) result (ren_scale) class(term_instance_t), intent(in) :: term real(default) :: ren_scale if (allocated (term%ren_scale)) then ren_scale = term%ren_scale else ren_scale = term%scale end if end function term_instance_get_ren_scale @ %def term_instance_get_fac_scale term_instance_get_ren_scale @ We take the strong coupling from the process core. The value is calculated when a new event is requested, so we should call it only after the event has been evaluated. If it is not available there (a negative number is returned), we take the value stored in the term configuration, which should be determined by the model. If the model does not provide a value, the result is zero. <>= procedure :: get_alpha_s => term_instance_get_alpha_s <>= module function term_instance_get_alpha_s (term, core) result (alpha_s) class(term_instance_t), intent(in) :: term class(prc_core_t), intent(in) :: core real(default) :: alpha_s end function term_instance_get_alpha_s <>= module function term_instance_get_alpha_s (term, core) result (alpha_s) class(term_instance_t), intent(in) :: term class(prc_core_t), intent(in) :: core real(default) :: alpha_s alpha_s = core%get_alpha_s (term%core_state) if (alpha_s < zero) alpha_s = term%config%alpha_s end function term_instance_get_alpha_s @ %def term_instance_get_alpha_s @ The second helicity for [[helicities]] comes with a minus sign because OpenLoops inverts the helicity index of antiparticles. <>= procedure :: get_helicities_for_openloops => & term_instance_get_helicities_for_openloops <>= module subroutine term_instance_get_helicities_for_openloops & (term, helicities) class(term_instance_t), intent(in) :: term integer, dimension(:,:), allocatable, intent(out) :: helicities end subroutine term_instance_get_helicities_for_openloops <>= module subroutine term_instance_get_helicities_for_openloops & (term, helicities) class(term_instance_t), intent(in) :: term integer, dimension(:,:), allocatable, intent(out) :: helicities type(helicity_t), dimension(:), allocatable :: hel type(quantum_numbers_t), dimension(:,:), allocatable :: qn type(quantum_numbers_mask_t) :: qn_mask integer :: h, i, j, n_in call qn_mask%set_sub (1) call term%isolated%trace%get_quantum_numbers_mask (qn_mask, qn) n_in = term%int_hard%get_n_in () allocate (helicities (size (qn, dim=1), n_in)) allocate (hel (n_in)) do i = 1, size (qn, dim=1) do j = 1, n_in hel(j) = qn(i, j)%get_helicity () call hel(j)%diagonalize () call hel(j)%get_indices (h, h) helicities (i, j) = h end do end do end subroutine term_instance_get_helicities_for_openloops @ %def term_instance_get_helicities_for_openloops @ <>= procedure :: get_i_term_global => term_instance_get_i_term_global <>= elemental module function term_instance_get_i_term_global & (term) result (i_term) integer :: i_term class(term_instance_t), intent(in) :: term end function term_instance_get_i_term_global <>= elemental module function term_instance_get_i_term_global & (term) result (i_term) integer :: i_term class(term_instance_t), intent(in) :: term i_term = term%config%i_term_global end function term_instance_get_i_term_global @ %def term_instance_get_i_term_global @ <>= procedure :: is_subtraction => term_instance_is_subtraction <>= elemental module function term_instance_is_subtraction (term) result (sub) logical :: sub class(term_instance_t), intent(in) :: term end function term_instance_is_subtraction <>= elemental module function term_instance_is_subtraction (term) result (sub) logical :: sub class(term_instance_t), intent(in) :: term sub = term%config%i_term_global == term%config%i_sub end function term_instance_is_subtraction @ %def term_instance_is_subtraction @ Retrieve [[n_sub]] which was calculated in [[process_term_setup_interaction]]. <>= procedure :: get_n_sub => term_instance_get_n_sub procedure :: get_n_sub_color => term_instance_get_n_sub_color procedure :: get_n_sub_spin => term_instance_get_n_sub_spin <>= module function term_instance_get_n_sub (term) result (n_sub) integer :: n_sub class(term_instance_t), intent(in) :: term end function term_instance_get_n_sub module function term_instance_get_n_sub_color (term) result (n_sub_color) integer :: n_sub_color class(term_instance_t), intent(in) :: term end function term_instance_get_n_sub_color module function term_instance_get_n_sub_spin (term) result (n_sub_spin) integer :: n_sub_spin class(term_instance_t), intent(in) :: term end function term_instance_get_n_sub_spin <>= module function term_instance_get_n_sub (term) result (n_sub) integer :: n_sub class(term_instance_t), intent(in) :: term n_sub = term%config%n_sub end function term_instance_get_n_sub module function term_instance_get_n_sub_color (term) result (n_sub_color) integer :: n_sub_color class(term_instance_t), intent(in) :: term n_sub_color = term%config%n_sub_color end function term_instance_get_n_sub_color module function term_instance_get_n_sub_spin (term) result (n_sub_spin) integer :: n_sub_spin class(term_instance_t), intent(in) :: term n_sub_spin = term%config%n_sub_spin end function term_instance_get_n_sub_spin @ %def term_instance_get_n_sub @ %def term_instance_get_n_sub_color @ %def term_instance_get_n_sub_spin @ \subsection{The process instance} NOTE: The description below represents the intended structure after refactoring and disentangling the FKS-NLO vs. LO algorithm dependencies. A process instance contains all process data that depend on the sampling point and thus change often. In essence, it is an event record at the elementary (parton) level. We do not call it such, to avoid confusion with the actual event records. If decays are involved, the latter are compositions of several elementary processes (i.e., their instances). We implement the process instance as an extension of the [[mci_sampler_t]] that we need for computing integrals and generate events. The base type contains: the [[integrand]], the [[selected_channel]], the two-dimensional array [[x]] of parameters, and the one-dimensional array [[f]] of Jacobians. These subobjects are public and used for communicating with the multi-channel integrator. The [[process]] pointer accesses the process of which this record is an instance. It is required whenever the calculation needs invariant configuration data, therefore the process should stay in memory for the whole lifetime of its instances. The [[pcm]] pointer is a shortcut to the [[pcm]] (process-component manager) component of the associated process, which we need wherever the calculation depends on the overall algorithm. The [[pcm_work]] component is the workspace for the [[pcm]] object referenced above. The [[evaluation_status]] code is used to check the current status. In particular, failure at various stages is recorded there. The [[count]] object records process evaluations, broken down according to status. The [[sqme]] value is the single real number that results from evaluating and tracing the kinematics and matrix elements. This is the number that is handed over to an integration routine. The [[weight]] value is the event weight. It is defined when an event has been generated from the process instance, either weighted or unweighted. The value is the [[sqme]] value times Jacobian weights from the integration, or unity, respectively. The [[i_mci]] index chooses a subset of components that are associated with a common parameter set and integrator, i.e., that are added coherently. The [[sf_chain]] subobject is a realization of the beam and structure-function configuration in the [[process]] object. It is not used for calculation directly but serves as the template for the sf-chain instances that are contained in the [[component]] objects. The [[kinematics]] array contains the set of phase-space points that are associated with the current calculation. The entries may correspond to different process components and terms. (TODO wk 19-02-22: Not implemented yet.) TODO wk 19-02-22: May include extra arrays for storing (squared) amplitude data. The [[term]] data set may be reduced to just results, or be removed altogether. The [[term]] subobjects are workspace for evaluating kinematics, matrix elements, cuts etc. The array entries correspond to the [[term]] configuration entries in the associated process object. The [[mci_work]] subobject contains the array of real input parameters (random numbers) that generates the kinematical point. It also contains the workspace for the MC integrators. The active entry of the [[mci_work]] array is selected by the [[i_mci]] index above. The [[hook]] pointer accesses a list of after evaluate objects which are evalutated after the matrix element. <>= public :: process_instance_t <>= type, extends (mci_sampler_t) :: process_instance_t type(process_t), pointer :: process => null () class(pcm_t), pointer :: pcm => null () class(pcm_workspace_t), allocatable :: pcm_work integer :: evaluation_status = STAT_UNDEFINED real(default) :: sqme = 0 real(default) :: weight = 0 real(default) :: excess = 0 integer :: n_dropped = 0 integer :: i_mci = 0 integer :: selected_channel = 0 type(sf_chain_t) :: sf_chain type(kinematics_t), dimension(:), allocatable :: kin type(term_instance_t), dimension(:), allocatable :: term type(mci_work_t), dimension(:), allocatable :: mci_work class(process_instance_hook_t), pointer :: hook => null () contains <> end type process_instance_t @ %def process_instance @ Wrapper type for storing pointers to process instance objects in arrays. <>= public :: process_instance_ptr_t <>= type :: process_instance_ptr_t type(process_instance_t), pointer :: p => null () end type process_instance_ptr_t @ %def process_instance_ptr_t @ The process hooks are first-in-last-out list of objects which are evaluated after the phase space and matrixelement are evaluated. It is possible to retrieve the sampler object and read the sampler information. The hook object are part of the [[process_instance]] and therefore, share a common lifetime. A data transfer, after the usual lifetime of the [[process_instance]], is not provided, as such the finalisation procedure has to take care of this! E.g. write the object to file from which later the collected information can then be retrieved. <>= public :: process_instance_hook_t <>= type, abstract :: process_instance_hook_t class(process_instance_hook_t), pointer :: next => null () contains procedure(process_instance_hook_init), deferred :: init procedure(process_instance_hook_final), deferred :: final procedure(process_instance_hook_evaluate), deferred :: evaluate end type process_instance_hook_t @ %def process_instance_hook_t @ We have to provide an [[init]], a [[final]] procedure and, for after evaluation, the [[evaluate]] procedure. The [[init]] procedures accesses [[var_list]] and current [[instance]] object. <>= public :: process_instance_hook_final, process_instance_hook_evaluate <>= abstract interface subroutine process_instance_hook_init (hook, var_list, instance, pdf_data) import :: process_instance_hook_t, var_list_t, process_instance_t, pdf_data_t class(process_instance_hook_t), intent(inout), target :: hook type(var_list_t), intent(in) :: var_list class(process_instance_t), intent(in), target :: instance type(pdf_data_t), intent(in), optional :: pdf_data end subroutine process_instance_hook_init subroutine process_instance_hook_final (hook) import :: process_instance_hook_t class(process_instance_hook_t), intent(inout) :: hook end subroutine process_instance_hook_final subroutine process_instance_hook_evaluate (hook, instance) import :: process_instance_hook_t, process_instance_t class(process_instance_hook_t), intent(inout) :: hook class(process_instance_t), intent(in), target :: instance end subroutine process_instance_hook_evaluate end interface @ %def process_instance_hook_final, process_instance_hook_evaluate @ The output routine contains a header with the most relevant information about the process, copied from [[process_metadata_write]]. We mark the active components by an asterisk. The next section is the MC parameter input. The following sections are written only if the evaluation status is beyond setting the parameters, or if the [[verbose]] option is set. <>= procedure :: write_header => process_instance_write_header procedure :: write => process_instance_write <>= module subroutine process_instance_write_header (object, unit, testflag) class(process_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine process_instance_write_header module subroutine process_instance_write (object, unit, testflag) class(process_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine process_instance_write <>= module subroutine process_instance_write_header (object, unit, testflag) class(process_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) call write_separator (u, 2) if (associated (object%process)) then call object%process%write_meta (u, testflag) else write (u, "(1x,A)") "Process instance [undefined process]" return end if write (u, "(3x,A)", advance = "no") "status = " select case (object%evaluation_status) case (STAT_INITIAL); write (u, "(A)") "initialized" case (STAT_ACTIVATED); write (u, "(A)") "activated" case (STAT_BEAM_MOMENTA); write (u, "(A)") "beam momenta set" case (STAT_FAILED_KINEMATICS); write (u, "(A)") "failed kinematics" case (STAT_SEED_KINEMATICS); write (u, "(A)") "seed kinematics" case (STAT_HARD_KINEMATICS); write (u, "(A)") "hard kinematics" case (STAT_EFF_KINEMATICS); write (u, "(A)") "effective kinematics" case (STAT_FAILED_CUTS); write (u, "(A)") "failed cuts" case (STAT_PASSED_CUTS); write (u, "(A)") "passed cuts" case (STAT_EVALUATED_TRACE); write (u, "(A)") "evaluated trace" call write_separator (u) write (u, "(3x,A,ES19.12)") "sqme = ", object%sqme case (STAT_EVENT_COMPLETE); write (u, "(A)") "event complete" call write_separator (u) write (u, "(3x,A,ES19.12)") "sqme = ", object%sqme write (u, "(3x,A,ES19.12)") "weight = ", object%weight if (.not. vanishes (object%excess)) & write (u, "(3x,A,ES19.12)") "excess = ", object%excess case default; write (u, "(A)") "undefined" end select if (object%i_mci /= 0) then call write_separator (u) call object%mci_work(object%i_mci)%write (u, testflag) end if call write_separator (u, 2) end subroutine process_instance_write_header module subroutine process_instance_write (object, unit, testflag) class(process_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u, i u = given_output_unit (unit) call object%write_header (u) if (object%evaluation_status >= STAT_BEAM_MOMENTA) then call object%sf_chain%write (u) call write_separator (u, 2) if (object%evaluation_status >= STAT_SEED_KINEMATICS) then if (object%evaluation_status >= STAT_HARD_KINEMATICS) then call write_separator (u, 2) write (u, "(1x,A)") "Active terms:" if (any (object%term%active)) then do i = 1, size (object%term) if (object%term(i)%active) then call write_separator (u) call object%term(i)%write (u, & kin = object%kin(i), & show_eff_state = & object%evaluation_status >= STAT_EFF_KINEMATICS, & testflag = testflag) end if end do end if end if call write_separator (u, 2) end if end if end subroutine process_instance_write @ %def process_instance_write_header @ %def process_instance_write @ Initialization connects the instance with a process. All initial information is transferred from the process object. The process object contains templates for the interaction subobjects (beam and term), but no evaluators. The initialization routine creates evaluators for the matrix element trace, other evaluators are left untouched. Before we start generating, we double-check if the process library has been updated after the process was initializated ([[check_library_sanity]]). This may happen if between integration and event generation the library has been recompiled, so all links become broken. The [[instance]] object must have the [[target]] attribute (also in any caller) since the initialization routine assigns various pointers to subobject of [[instance]]. <>= procedure :: init => process_instance_init <>= module subroutine process_instance_init (instance, process) class(process_instance_t), intent(out), target :: instance type(process_t), intent(inout), target :: process end subroutine process_instance_init <>= module subroutine process_instance_init (instance, process) class(process_instance_t), intent(out), target :: instance type(process_t), intent(inout), target :: process integer :: i class(pcm_t), pointer :: pcm type(process_term_t), pointer :: term type(var_list_t), pointer :: var_list integer :: i_born, i_real, i_real_fin, i_component if (debug_on) call msg_debug & (D_PROCESS_INTEGRATION, "process_instance_init") instance%process => process instance%pcm => process%get_pcm_ptr () call instance%process%check_library_sanity () call instance%setup_sf_chain (process%get_beam_config_ptr ()) allocate (instance%mci_work (process%get_n_mci ())) do i = 1, size (instance%mci_work) call instance%process%init_mci_work (instance%mci_work(i), i) end do call instance%process%reset_selected_cores () pcm => instance%process%get_pcm_ptr () call pcm%allocate_workspace (instance%pcm_work) select type (pcm) type is (pcm_nlo_t) !!! The process is kept when the integration is finalized, but not the !!! process_instance. Thus, we check whether pcm has been initialized !!! but set up the pcm_work each time. i_real_fin = process%get_associated_real_fin (1) if (.not. pcm%initialized) then i_born = pcm%get_i_core (pcm%i_born) i_real = pcm%get_i_core (pcm%i_real) call pcm%init_qn (process%get_model_ptr ()) if (i_real_fin > 0) call pcm%allocate_ps_matching () var_list => process%get_var_list_ptr () if (var_list%get_sval (var_str ("$dalitz_plot")) /= var_str ('')) & call pcm%activate_dalitz_plot (var_list%get_sval (var_str ("$dalitz_plot"))) end if pcm%initialized = .true. select type (pcm_work => instance%pcm_work) type is (pcm_nlo_workspace_t) call pcm_work%init_config (pcm, & process%component_can_be_integrated (), & process%get_nlo_type_component (), process%get_energy (), & i_real_fin, process%get_model_ptr ()) end select end select ! TODO wk-03-01 n_terms will eventually acquire a different meaning allocate (instance%kin (process%get_n_terms ())) do i = 1, process%get_n_terms () term => process%get_term_ptr (i) i_component = term%i_component call instance%kin(i)%configure (pcm, instance%pcm_work, & instance%sf_chain, & process%get_beam_config_ptr (), & process%get_phs_config (i_component), & process%get_nlo_type_component (i_component), & term%i_sub == i) end do ! TODO wk-03-01 n_terms will eventually acquire a different meaning allocate (instance%term (process%get_n_terms ())) do i = 1, process%get_n_terms () call instance%term(i)%configure (process, i, instance%pcm_work, & instance%sf_chain, instance%kin(i)) end do call instance%set_i_mci_to_real_component () call instance%find_same_kinematics () instance%evaluation_status = STAT_INITIAL end subroutine process_instance_init @ %def process_instance_init @ @ Finalize all subobjects that may contain allocated pointers. <>= procedure :: final => process_instance_final <>= module subroutine process_instance_final (instance) class(process_instance_t), intent(inout) :: instance end subroutine process_instance_final <>= module subroutine process_instance_final (instance) class(process_instance_t), intent(inout) :: instance class(process_instance_hook_t), pointer :: current integer :: i instance%process => null () if (allocated (instance%mci_work)) then do i = 1, size (instance%mci_work) call instance%mci_work(i)%final () end do deallocate (instance%mci_work) end if call instance%sf_chain%final () if (allocated (instance%kin)) then do i = 1, size (instance%kin) call instance%kin(i)%final () end do deallocate (instance%kin) end if if (allocated (instance%term)) then do i = 1, size (instance%term) call instance%term(i)%final () end do deallocate (instance%term) end if call instance%pcm_work%final () instance%evaluation_status = STAT_UNDEFINED do while (associated (instance%hook)) current => instance%hook call current%final () instance%hook => current%next deallocate (current) end do instance%hook => null () end subroutine process_instance_final @ %def process_instance_final @ Revert the process instance to initial state. We do not deallocate anything, just reset the state index and deactivate all components and terms. We do not reset the choice of the MCI set [[i_mci]] unless this is required explicitly. <>= procedure :: reset => process_instance_reset <>= module subroutine process_instance_reset (instance, reset_mci) class(process_instance_t), intent(inout), target :: instance logical, intent(in), optional :: reset_mci end subroutine process_instance_reset <>= module subroutine process_instance_reset (instance, reset_mci) class(process_instance_t), intent(inout), target :: instance logical, intent(in), optional :: reset_mci integer :: i call instance%process%reset_selected_cores () do i = 1, size (instance%term) call instance%term(i)%reset () end do instance%term%checked = .false. instance%term%passed = .false. instance%kin%new_seed = .true. if (present (reset_mci)) then if (reset_mci) instance%i_mci = 0 end if instance%selected_channel = 0 instance%evaluation_status = STAT_INITIAL end subroutine process_instance_reset @ %def process_instance_reset @ \subsubsection{Integration and event generation} The sampler test should just evaluate the squared matrix element [[n_calls]] times, discarding the results, and return. This can be done before integration, e.g., for timing estimates. <>= procedure :: sampler_test => process_instance_sampler_test <>= module subroutine process_instance_sampler_test (instance, i_mci, n_calls) class(process_instance_t), intent(inout), target :: instance integer, intent(in) :: i_mci integer, intent(in) :: n_calls end subroutine process_instance_sampler_test <>= module subroutine process_instance_sampler_test (instance, i_mci, n_calls) class(process_instance_t), intent(inout), target :: instance integer, intent(in) :: i_mci integer, intent(in) :: n_calls integer :: i_mci_work i_mci_work = instance%process%get_i_mci_work (i_mci) call instance%choose_mci (i_mci_work) call instance%reset_counter () call instance%process%sampler_test (instance, n_calls, i_mci_work) call instance%process%set_counter_mci_entry (i_mci_work, instance%get_counter ()) end subroutine process_instance_sampler_test @ %def process_instance_sampler_test @ Generate a weighted event. We select one of the available MCI integrators by its index [[i_mci]] and thus generate an event for the associated (group of) process component(s). The arguments exactly correspond to the initializer and finalizer above. The resulting event is stored in the [[process_instance]] object, which also holds the workspace of the integrator. Note: The [[process]] object contains the random-number state, which changes for each event. Otherwise, all volatile data are inside the [[instance]] object. <>= procedure :: generate_weighted_event => & process_instance_generate_weighted_event <>= module subroutine process_instance_generate_weighted_event (instance, i_mci) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci end subroutine process_instance_generate_weighted_event <>= module subroutine process_instance_generate_weighted_event (instance, i_mci) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci integer :: i_mci_work i_mci_work = instance%process%get_i_mci_work (i_mci) call instance%choose_mci (i_mci_work) associate (mci_work => instance%mci_work(i_mci_work)) call instance%process%generate_weighted_event & (i_mci_work, mci_work, instance, & instance%keep_failed_events ()) end associate end subroutine process_instance_generate_weighted_event @ %def process_instance_generate_weighted_event @ <>= procedure :: generate_unweighted_event => & process_instance_generate_unweighted_event <>= module subroutine process_instance_generate_unweighted_event & (instance, i_mci) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci end subroutine process_instance_generate_unweighted_event <>= module subroutine process_instance_generate_unweighted_event (instance, i_mci) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci integer :: i_mci_work i_mci_work = instance%process%get_i_mci_work (i_mci) call instance%choose_mci (i_mci_work) associate (mci_work => instance%mci_work(i_mci_work)) call instance%process%generate_unweighted_event & (i_mci_work, mci_work, instance) end associate end subroutine process_instance_generate_unweighted_event @ %def process_instance_generate_unweighted_event -@ -This replaces the event generation methods for the situation that the +@ This replaces the event generation methods for the situation that the process instance object has been filled by other means (i.e., reading and/or recalculating its contents). We just have to fill in missing MCI data, especially the event weight. <>= procedure :: recover_event => process_instance_recover_event <>= module subroutine process_instance_recover_event (instance) class(process_instance_t), intent(inout) :: instance end subroutine process_instance_recover_event <>= module subroutine process_instance_recover_event (instance) class(process_instance_t), intent(inout) :: instance integer :: i_mci i_mci = instance%i_mci call instance%process%set_i_mci_work (i_mci) associate (mci_instance => instance%mci_work(i_mci)%mci) call mci_instance%fetch (instance, instance%selected_channel) end associate end subroutine process_instance_recover_event @ %def process_instance_recover_event -@ @ Activate the components and terms that correspond to a currently selected MCI parameter set. <>= procedure :: activate => process_instance_activate <>= module subroutine process_instance_activate (instance) class(process_instance_t), intent(inout) :: instance end subroutine process_instance_activate <>= module subroutine process_instance_activate (instance) class(process_instance_t), intent(inout) :: instance integer :: i, j integer, dimension(:), allocatable :: i_term associate (mci_work => instance%mci_work(instance%i_mci)) call instance%process%select_components & (mci_work%get_active_components ()) end associate associate (process => instance%process) do i = 1, instance%process%get_n_components () if (instance%process%component_is_selected (i)) then allocate (i_term (size (process%get_component_i_terms (i)))) i_term = process%get_component_i_terms (i) do j = 1, size (i_term) instance%term(i_term(j))%active = .true. end do end if if (allocated (i_term)) deallocate (i_term) end do end associate instance%evaluation_status = STAT_ACTIVATED end subroutine process_instance_activate @ %def process_instance_activate @ <>= procedure :: find_same_kinematics => process_instance_find_same_kinematics <>= module subroutine process_instance_find_same_kinematics (instance) class(process_instance_t), intent(inout) :: instance end subroutine process_instance_find_same_kinematics <>= module subroutine process_instance_find_same_kinematics (instance) class(process_instance_t), intent(inout) :: instance integer :: i_term1, i_term2, k, n_same do i_term1 = 1, size (instance%term) if (.not. allocated (instance%term(i_term1)%same_kinematics)) then n_same = 1 !!! Index group includes the index of its term_instance do i_term2 = 1, size (instance%term) if (i_term1 == i_term2) cycle if (compare_md5s (i_term1, i_term2)) n_same = n_same + 1 end do allocate (instance%term(i_term1)%same_kinematics (n_same)) associate (same_kinematics1 => instance%term(i_term1)%same_kinematics) same_kinematics1 = 0 k = 1 do i_term2 = 1, size (instance%term) if (compare_md5s (i_term1, i_term2)) then same_kinematics1(k) = i_term2 k = k + 1 end if end do do k = 1, size (same_kinematics1) if (same_kinematics1(k) == i_term1) cycle i_term2 = same_kinematics1(k) allocate (instance%term(i_term2)%same_kinematics (n_same)) instance%term(i_term2)%same_kinematics = same_kinematics1 end do end associate end if end do contains function compare_md5s (i, j) result (same) logical :: same integer, intent(in) :: i, j character(32) :: md5sum_1, md5sum_2 integer :: mode_1, mode_2 mode_1 = 0; mode_2 = 0 select type (phs => instance%kin(i)%phs%config) type is (phs_fks_config_t) md5sum_1 = phs%md5sum_born_config mode_1 = phs%mode class default md5sum_1 = phs%md5sum_phs_config end select select type (phs => instance%kin(j)%phs%config) type is (phs_fks_config_t) md5sum_2 = phs%md5sum_born_config mode_2 = phs%mode class default md5sum_2 = phs%md5sum_phs_config end select same = (md5sum_1 == md5sum_2) .and. (mode_1 == mode_2) end function compare_md5s end subroutine process_instance_find_same_kinematics @ %def process_instance_find_same_kinematics @ <>= procedure :: transfer_same_kinematics => & process_instance_transfer_same_kinematics <>= module subroutine process_instance_transfer_same_kinematics & (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term end subroutine process_instance_transfer_same_kinematics <>= module subroutine process_instance_transfer_same_kinematics (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term integer :: i, i_term_same associate (same_kinematics => instance%term(i_term)%same_kinematics) do i = 1, size (same_kinematics) i_term_same = same_kinematics(i) instance%term(i_term_same)%p_seed = instance%term(i_term)%p_seed associate (phs => instance%kin(i_term_same)%phs) call phs%set_lorentz_transformation & (instance%kin(i_term)%phs%get_lorentz_transformation ()) select type (phs) type is (phs_fks_t) call phs%set_momenta (instance%term(i_term_same)%p_seed) if (i_term_same /= i_term) then call phs%set_reference_frames (.false.) end if end select end associate instance%kin(i_term_same)%new_seed = .false. end do end associate end subroutine process_instance_transfer_same_kinematics @ %def process_instance_transfer_same_kinematics @ <>= procedure :: redo_sf_chains => process_instance_redo_sf_chains <>= module subroutine process_instance_redo_sf_chains & (instance, i_term, phs_channel) class(process_instance_t), intent(inout) :: instance integer, intent(in), dimension(:) :: i_term integer, intent(in) :: phs_channel end subroutine process_instance_redo_sf_chains <>= module subroutine process_instance_redo_sf_chains & (instance, i_term, phs_channel) class(process_instance_t), intent(inout) :: instance integer, intent(in), dimension(:) :: i_term integer, intent(in) :: phs_channel integer :: i do i = 1, size (i_term) call instance%kin(i_term(i))%redo_sf_chain & (instance%mci_work(instance%i_mci), phs_channel) end do end subroutine process_instance_redo_sf_chains @ %def process_instance_redo_sf_chains @ Integrate the process, using a previously initialized process instance. We select one of the available MCI integrators by its index [[i_mci]] and thus integrate over (structure functions and) phase space for the associated (group of) process component(s). <>= procedure :: integrate => process_instance_integrate <>= module subroutine process_instance_integrate (instance, i_mci, & n_it, n_calls, adapt_grids, adapt_weights, final, pacify) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: adapt_grids logical, intent(in), optional :: adapt_weights logical, intent(in), optional :: final, pacify end subroutine process_instance_integrate <>= module subroutine process_instance_integrate (instance, i_mci, & n_it, n_calls, adapt_grids, adapt_weights, final, pacify) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: adapt_grids logical, intent(in), optional :: adapt_weights logical, intent(in), optional :: final, pacify integer :: nlo_type, i_mci_work nlo_type = instance%process%get_component_nlo_type (i_mci) i_mci_work = instance%process%get_i_mci_work (i_mci) call instance%choose_mci (i_mci_work) call instance%reset_counter () associate (mci_work => instance%mci_work(i_mci_work), & process => instance%process) call process%integrate (i_mci_work, mci_work, & instance, n_it, n_calls, adapt_grids, adapt_weights, & final, pacify, nlo_type = nlo_type) call process%set_counter_mci_entry (i_mci_work, instance%get_counter ()) end associate end subroutine process_instance_integrate @ %def process_instance_integrate @ Subroutine of the initialization above: initialize the beam and structure-function chain template. We establish pointers to the configuration data, so [[beam_config]] must have a [[target]] attribute. The resulting chain is not used directly for calculation. It will acquire instances which are stored in the process-component instance objects. <>= procedure :: setup_sf_chain => process_instance_setup_sf_chain <>= module subroutine process_instance_setup_sf_chain (instance, config) class(process_instance_t), intent(inout) :: instance type(process_beam_config_t), intent(in), target :: config end subroutine process_instance_setup_sf_chain <>= module subroutine process_instance_setup_sf_chain (instance, config) class(process_instance_t), intent(inout) :: instance type(process_beam_config_t), intent(in), target :: config integer :: n_strfun n_strfun = config%n_strfun if (n_strfun /= 0) then call instance%sf_chain%init (config%data, config%sf) else call instance%sf_chain%init (config%data) end if if (config%sf_trace) then call instance%sf_chain%setup_tracing (config%sf_trace_file) end if end subroutine process_instance_setup_sf_chain @ %def process_instance_setup_sf_chain @ This initialization routine should be called only for process instances which we intend as a source for physical events. It initializes the evaluators in the parton states of the terms. They describe the (semi-)exclusive transition matrix and the distribution of color flow for the partonic process, convoluted with the beam and structure-function chain. If the model is not provided explicitly, we may use the model instance that belongs to the process. However, an explicit model allows us to override particle settings. <>= procedure :: setup_event_data => process_instance_setup_event_data <>= module subroutine process_instance_setup_event_data & (instance, model, i_core) class(process_instance_t), intent(inout), target :: instance class(model_data_t), intent(in), optional, target :: model integer, intent(in), optional :: i_core end subroutine process_instance_setup_event_data <>= module subroutine process_instance_setup_event_data (instance, model, i_core) class(process_instance_t), intent(inout), target :: instance class(model_data_t), intent(in), optional, target :: model integer, intent(in), optional :: i_core class(model_data_t), pointer :: current_model integer :: i class(prc_core_t), pointer :: core => null () if (present (model)) then current_model => model else current_model => instance%process%get_model_ptr () end if do i = 1, size (instance%term) associate (term => instance%term(i), kin => instance%kin(i)) if (associated (term%config)) then core => instance%process%get_core_term (i) call term%setup_event_data (kin, core, current_model) end if end associate end do core => null () end subroutine process_instance_setup_event_data @ %def process_instance_setup_event_data @ Choose a MC parameter set and the corresponding integrator. The choice persists beyond calls of the [[reset]] method above. This method is automatically called here. <>= procedure :: choose_mci => process_instance_choose_mci <>= module subroutine process_instance_choose_mci (instance, i_mci) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci end subroutine process_instance_choose_mci <>= module subroutine process_instance_choose_mci (instance, i_mci) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci instance%i_mci = i_mci call instance%reset () end subroutine process_instance_choose_mci @ %def process_instance_choose_mci @ Explicitly set a MC parameter set. Works only if we are in initial state. We assume that the length of the parameter set is correct. After setting the parameters, activate the components and terms that correspond to the chosen MC parameter set. The [[warmup_flag]] is used when a dummy phase-space point is computed for the warmup of e.g. OpenLoops helicities. The setting of the the [[evaluation_status]] has to be avoided then. <>= procedure :: set_mcpar => process_instance_set_mcpar <>= module subroutine process_instance_set_mcpar (instance, x, warmup_flag) class(process_instance_t), intent(inout) :: instance real(default), dimension(:), intent(in) :: x logical, intent(in), optional :: warmup_flag end subroutine process_instance_set_mcpar <>= module subroutine process_instance_set_mcpar (instance, x, warmup_flag) class(process_instance_t), intent(inout) :: instance real(default), dimension(:), intent(in) :: x logical, intent(in), optional :: warmup_flag logical :: activate activate = .true.; if (present (warmup_flag)) activate = .not. warmup_flag if (instance%evaluation_status == STAT_INITIAL) then associate (mci_work => instance%mci_work(instance%i_mci)) call mci_work%set (x) end associate if (activate) call instance%activate () end if end subroutine process_instance_set_mcpar @ %def process_instance_set_mcpar @ Receive the beam momentum/momenta from a source interaction. This applies to a cascade decay process instance, where the `beam' momentum varies event by event. The master beam momentum array is contained in the main structure function chain subobject [[sf_chain]]. The sf-chain instance that reside in the components will take their beam momenta from there. The procedure transforms the instance status into [[STAT_BEAM_MOMENTA]]. For process instance with fixed beam, this intermediate status is skipped. <>= procedure :: receive_beam_momenta => process_instance_receive_beam_momenta <>= module subroutine process_instance_receive_beam_momenta (instance) class(process_instance_t), intent(inout) :: instance end subroutine process_instance_receive_beam_momenta <>= module subroutine process_instance_receive_beam_momenta (instance) class(process_instance_t), intent(inout) :: instance if (instance%evaluation_status >= STAT_INITIAL) then call instance%sf_chain%receive_beam_momenta () instance%evaluation_status = STAT_BEAM_MOMENTA end if end subroutine process_instance_receive_beam_momenta @ %def process_instance_receive_beam_momenta @ Set the beam momentum/momenta explicitly. Otherwise, analogous to the previous procedure. <>= procedure :: set_beam_momenta => process_instance_set_beam_momenta <>= module subroutine process_instance_set_beam_momenta (instance, p) class(process_instance_t), intent(inout) :: instance type(vector4_t), dimension(:), intent(in) :: p end subroutine process_instance_set_beam_momenta <>= module subroutine process_instance_set_beam_momenta (instance, p) class(process_instance_t), intent(inout) :: instance type(vector4_t), dimension(:), intent(in) :: p if (instance%evaluation_status >= STAT_INITIAL) then call instance%sf_chain%set_beam_momenta (p) instance%evaluation_status = STAT_BEAM_MOMENTA end if end subroutine process_instance_set_beam_momenta @ %def process_instance_set_beam_momenta @ Recover the initial beam momenta (those in the [[sf_chain]] component), given a valid (recovered) [[sf_chain_instance]] in one of the active components. We need to do this only if the lab frame is not the c.m.\ frame, otherwise those beams would be fixed anyway. <>= procedure :: recover_beam_momenta => process_instance_recover_beam_momenta <>= module subroutine process_instance_recover_beam_momenta (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term end subroutine process_instance_recover_beam_momenta <>= module subroutine process_instance_recover_beam_momenta (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term if (.not. instance%process%lab_is_cm ()) then if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then call instance%kin(i_term)%return_beam_momenta () end if end if end subroutine process_instance_recover_beam_momenta @ %def process_instance_recover_beam_momenta @ Explicitly choose MC integration channel. We assume here that the channel count is identical for all active components. <>= procedure :: select_channel => process_instance_select_channel <>= module subroutine process_instance_select_channel (instance, channel) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: channel end subroutine process_instance_select_channel <>= module subroutine process_instance_select_channel (instance, channel) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: channel instance%selected_channel = channel end subroutine process_instance_select_channel @ %def process_instance_select_channel @ First step of process evaluation: set up seed kinematics. That is, for each active process component, compute a momentum array from the MC input parameters. If [[skip_term]] is set, we skip the component that accesses this term. We can assume that the associated data have already been recovered, and we are just computing the rest. <>= procedure :: compute_seed_kinematics => & process_instance_compute_seed_kinematics <>= module subroutine process_instance_compute_seed_kinematics & (instance, recover, skip_term) class(process_instance_t), intent(inout) :: instance logical, intent(in), optional :: recover integer, intent(in), optional :: skip_term end subroutine process_instance_compute_seed_kinematics <>= module subroutine process_instance_compute_seed_kinematics & (instance, recover, skip_term) class(process_instance_t), intent(inout) :: instance logical, intent(in), optional :: recover integer, intent(in), optional :: skip_term integer :: channel, skip_component, i, j logical :: success integer, dimension(:), allocatable :: i_term channel = instance%selected_channel if (channel == 0) then call msg_bug ("Compute seed kinematics: undefined integration channel") end if if (present (skip_term)) then skip_component = instance%term(skip_term)%config%i_component else skip_component = 0 end if if (present (recover)) then if (recover) return end if if (instance%evaluation_status >= STAT_ACTIVATED) then success = .true. do i = 1, instance%process%get_n_components () if (i == skip_component) cycle if (instance%process%component_is_selected (i)) then allocate (i_term (size (instance%process%get_component_i_terms (i)))) i_term = instance%process%get_component_i_terms (i) do j = 1, size (i_term) associate (term => instance%term(i_term(j)), kin => instance%kin(i_term(j))) if (kin%new_seed) then call term%compute_seed_kinematics (kin, & instance%mci_work(instance%i_mci), channel, success) call instance%transfer_same_kinematics (i_term(j)) end if if (.not. success) exit select type (pcm => instance%pcm) class is (pcm_nlo_t) call term%evaluate_projections (kin) call kin%evaluate_radiation_kinematics & (instance%mci_work(instance%i_mci)%get_x_process ()) call kin%generate_fsr_in () call kin%compute_xi_ref_momenta (pcm%region_data, term%nlo_type) end select end associate end do end if if (allocated (i_term)) deallocate (i_term) end do if (success) then instance%evaluation_status = STAT_SEED_KINEMATICS else instance%evaluation_status = STAT_FAILED_KINEMATICS end if end if associate (mci_work => instance%mci_work(instance%i_mci)) select type (pcm_work => instance%pcm_work) class is (pcm_nlo_workspace_t) call pcm_work%set_x_rad (mci_work%get_x_process ()) end select end associate end subroutine process_instance_compute_seed_kinematics @ %def process_instance_compute_seed_kinematics @ <>= procedure :: get_x_process => process_instance_get_x_process <>= pure module function process_instance_get_x_process (instance) result (x) real(default), dimension(:), allocatable :: x class(process_instance_t), intent(in) :: instance end function process_instance_get_x_process <>= pure module function process_instance_get_x_process (instance) result (x) real(default), dimension(:), allocatable :: x class(process_instance_t), intent(in) :: instance allocate (x(size (instance%mci_work(instance%i_mci)%get_x_process ()))) x = instance%mci_work(instance%i_mci)%get_x_process () end function process_instance_get_x_process @ %def process_instance_get_x_process @ <>= procedure :: get_active_component_type => & process_instance_get_active_component_type <>= pure module function process_instance_get_active_component_type & (instance) result (nlo_type) integer :: nlo_type class(process_instance_t), intent(in) :: instance end function process_instance_get_active_component_type <>= pure module function process_instance_get_active_component_type & (instance) result (nlo_type) integer :: nlo_type class(process_instance_t), intent(in) :: instance nlo_type = instance%process%get_component_nlo_type (instance%i_mci) end function process_instance_get_active_component_type @ %def process_instance_get_active_component_type @ Inverse: recover missing parts of the kinematics from the momentum configuration, which we know for a single term and component. Given a channel, reconstruct the MC parameter set. <>= procedure :: recover_mcpar => process_instance_recover_mcpar <>= module subroutine process_instance_recover_mcpar (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term end subroutine process_instance_recover_mcpar <>= module subroutine process_instance_recover_mcpar (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term integer :: channel, i if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then channel = instance%selected_channel if (channel == 0) then call msg_bug ("Recover MC parameters: undefined integration channel") end if call instance%kin(i_term)%recover_mcpar & (instance%mci_work(instance%i_mci), channel, instance%term(i_term)%p_seed) if (instance%term(i_term)%nlo_type == NLO_REAL) then do i = 1, size (instance%term) if (i /= i_term .and. instance%term(i)%nlo_type == NLO_REAL) then if (instance%term(i)%active) then call instance%kin(i)%recover_mcpar & (instance%mci_work(instance%i_mci), channel, & instance%term(i)%p_seed) end if end if end do end if end if end subroutine process_instance_recover_mcpar @ %def process_instance_recover_mcpar @ This is part of [[recover_mcpar]], extracted for the case when there is no phase space and parameters to recover, but we still need the structure function kinematics for evaluation. <>= procedure :: recover_sfchain => process_instance_recover_sfchain <>= module subroutine process_instance_recover_sfchain (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term end subroutine process_instance_recover_sfchain <>= module subroutine process_instance_recover_sfchain (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term integer :: channel if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then channel = instance%selected_channel if (channel == 0) then call msg_bug ("Recover sfchain: undefined integration channel") end if call instance%kin(i_term)%recover_sfchain & (channel, instance%term(i_term)%p_seed) end if end subroutine process_instance_recover_sfchain @ %def process_instance_recover_sfchain @ Second step of process evaluation: compute all momenta, for all active components, from the seed kinematics. <>= procedure :: compute_hard_kinematics => & process_instance_compute_hard_kinematics <>= module subroutine process_instance_compute_hard_kinematics & (instance, recover, skip_term) class(process_instance_t), intent(inout) :: instance integer, intent(in), optional :: skip_term logical, intent(in), optional :: recover end subroutine process_instance_compute_hard_kinematics <>= module subroutine process_instance_compute_hard_kinematics & (instance, recover, skip_term) class(process_instance_t), intent(inout) :: instance integer, intent(in), optional :: skip_term logical, intent(in), optional :: recover integer :: i logical :: success success = .true. if (instance%evaluation_status >= STAT_SEED_KINEMATICS) then do i = 1, size (instance%term) associate (term => instance%term(i), kin => instance%kin(i)) if (term%active) then call term%compute_hard_kinematics & (kin, recover, skip_term, success) if (.not. success) exit !!! Ren scale is zero when this is commented out! Understand! if (term%nlo_type == NLO_REAL) & call kin%redo_sf_chain (instance%mci_work(instance%i_mci), & instance%selected_channel) end if end associate end do if (success) then instance%evaluation_status = STAT_HARD_KINEMATICS else instance%evaluation_status = STAT_FAILED_KINEMATICS end if end if end subroutine process_instance_compute_hard_kinematics @ %def process_instance_setup_compute_hard_kinematics @ Inverse: recover seed kinematics. We know the beam momentum configuration and the outgoing momenta of the effective interaction, for one specific term. <>= procedure :: recover_seed_kinematics => & process_instance_recover_seed_kinematics <>= module subroutine process_instance_recover_seed_kinematics & (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term end subroutine process_instance_recover_seed_kinematics <>= module subroutine process_instance_recover_seed_kinematics (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term type(vector4_t), dimension(:), allocatable :: p_seed_ref integer :: i if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then call instance%term(i_term)%recover_seed_kinematics (instance%kin(i_term)) if (instance%term(i_term)%nlo_type == NLO_REAL) then allocate (p_seed_ref & (instance%term(i_term)%isolated%int_eff%get_n_out ())) p_seed_ref = instance%term(i_term)%isolated%int_eff%get_momenta & (outgoing = .true.) do i = 1, size (instance%term) if (i /= i_term .and. instance%term(i)%nlo_type == NLO_REAL) then if (instance%term(i)%active) then call instance%term(i)%recover_seed_kinematics & (instance%kin(i), p_seed_ref) end if end if end do end if end if end subroutine process_instance_recover_seed_kinematics @ %def process_instance_recover_seed_kinematics @ Third step of process evaluation: compute the effective momentum configurations, for all active terms, from the hard kinematics. <>= procedure :: compute_eff_kinematics => & process_instance_compute_eff_kinematics <>= module subroutine process_instance_compute_eff_kinematics & (instance, skip_term) class(process_instance_t), intent(inout) :: instance integer, intent(in), optional :: skip_term end subroutine process_instance_compute_eff_kinematics <>= module subroutine process_instance_compute_eff_kinematics & (instance, skip_term) class(process_instance_t), intent(inout) :: instance integer, intent(in), optional :: skip_term integer :: i if (instance%evaluation_status >= STAT_HARD_KINEMATICS) then do i = 1, size (instance%term) if (present (skip_term)) then if (i == skip_term) cycle end if if (instance%term(i)%active) then call instance%term(i)%compute_eff_kinematics () end if end do instance%evaluation_status = STAT_EFF_KINEMATICS end if end subroutine process_instance_compute_eff_kinematics @ %def process_instance_setup_compute_eff_kinematics @ Inverse: recover the hard kinematics from effective kinematics for one term, then compute effective kinematics for the other terms. <>= procedure :: recover_hard_kinematics => & process_instance_recover_hard_kinematics <>= module subroutine process_instance_recover_hard_kinematics & (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term end subroutine process_instance_recover_hard_kinematics <>= module subroutine process_instance_recover_hard_kinematics (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term integer :: i if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then call instance%term(i_term)%recover_hard_kinematics () do i = 1, size (instance%term) if (i /= i_term) then if (instance%term(i)%active) then call instance%term(i)%compute_eff_kinematics () end if end if end do instance%evaluation_status = STAT_EFF_KINEMATICS end if end subroutine process_instance_recover_hard_kinematics @ %def recover_hard_kinematics @ Fourth step of process evaluation: check cuts for all terms. Where successful, compute any scales and weights. Otherwise, deactive the term. If any of the terms has passed, set the state to [[STAT_PASSED_CUTS]]. The argument [[scale_forced]], if present, will override the scale calculation in the term expressions. <>= procedure :: evaluate_expressions => & process_instance_evaluate_expressions <>= module subroutine process_instance_evaluate_expressions & (instance, scale_forced) class(process_instance_t), intent(inout) :: instance real(default), intent(in), allocatable, optional :: scale_forced end subroutine process_instance_evaluate_expressions <>= module subroutine process_instance_evaluate_expressions & (instance, scale_forced) class(process_instance_t), intent(inout) :: instance real(default), intent(in), allocatable, optional :: scale_forced integer :: i logical :: passed_real if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then do i = 1, size (instance%term) if (instance%term(i)%active) then call instance%term(i)%evaluate_expressions & (instance%process%get_beam_config (), scale_forced) end if end do call evaluate_real_scales_and_cuts () call set_ellis_sexton_scale () if (.not. passed_real) then instance%evaluation_status = STAT_FAILED_CUTS else if (any (instance%term%passed)) then instance%evaluation_status = STAT_PASSED_CUTS else instance%evaluation_status = STAT_FAILED_CUTS end if end if end if contains subroutine evaluate_real_scales_and_cuts () integer :: i passed_real = .true. select type (pcm => instance%pcm) type is (pcm_nlo_t) do i = 1, size (instance%term) if (instance%term(i)%active .and. instance%term(i)%nlo_type == NLO_REAL) then if (pcm%settings%cut_all_real_sqmes) & passed_real = passed_real .and. instance%term(i)%passed if (pcm%settings%use_born_scale) & call replace_scales (instance%term(i)) end if end do end select end subroutine evaluate_real_scales_and_cuts subroutine replace_scales (this_term) type(term_instance_t), intent(inout) :: this_term integer :: i_sub i_sub = this_term%config%i_sub if (this_term%config%i_term_global /= i_sub .and. i_sub > 0) then this_term%ren_scale = instance%term(i_sub)%ren_scale this_term%fac_scale = instance%term(i_sub)%fac_scale end if end subroutine replace_scales subroutine set_ellis_sexton_scale () real(default) :: es_scale type(var_list_t), pointer :: var_list integer :: i var_list => instance%process%get_var_list_ptr () es_scale = var_list%get_rval (var_str ("ellis_sexton_scale")) do i = 1, size (instance%term) if (instance%term(i)%active .and. instance%term(i)%nlo_type == NLO_VIRTUAL) then if (es_scale > zero) then if (allocated (instance%term(i)%es_scale)) then instance%term(i)%es_scale = es_scale else allocate (instance%term(i)%es_scale, source=es_scale) end if end if end if end do end subroutine set_ellis_sexton_scale end subroutine process_instance_evaluate_expressions @ %def process_instance_evaluate_expressions @ Fifth step of process evaluation: fill the parameters for the non-selected channels, that have not been used for seeding. We should do this after evaluating cuts, since we may save some expensive calculations if the phase space point fails the cuts. If [[skip_term]] is set, we skip the component that accesses this term. We can assume that the associated data have already been recovered, and we are just computing the rest. <>= procedure :: compute_other_channels => & process_instance_compute_other_channels <>= module subroutine process_instance_compute_other_channels & (instance, skip_term) class(process_instance_t), intent(inout) :: instance integer, intent(in), optional :: skip_term end subroutine process_instance_compute_other_channels <>= module subroutine process_instance_compute_other_channels & (instance, skip_term) class(process_instance_t), intent(inout) :: instance integer, intent(in), optional :: skip_term integer :: channel, skip_component, i, j integer, dimension(:), allocatable :: i_term channel = instance%selected_channel if (channel == 0) then call msg_bug ("Compute other channels: undefined integration channel") end if if (present (skip_term)) then skip_component = instance%term(skip_term)%config%i_component else skip_component = 0 end if if (instance%evaluation_status >= STAT_PASSED_CUTS) then do i = 1, instance%process%get_n_components () if (i == skip_component) cycle if (instance%process%component_is_selected (i)) then allocate (i_term (size (instance%process%get_component_i_terms (i)))) i_term = instance%process%get_component_i_terms (i) do j = 1, size (i_term) call instance%kin(i_term(j))%compute_other_channels & (instance%mci_work(instance%i_mci), channel) end do end if if (allocated (i_term)) deallocate (i_term) end do end if end subroutine process_instance_compute_other_channels @ %def process_instance_compute_other_channels @ If not done otherwise, we flag the kinematics as new for the core state, such that the routine below will actually compute the matrix element and not just look it up. <>= procedure :: reset_core_kinematics => process_instance_reset_core_kinematics <>= module subroutine process_instance_reset_core_kinematics (instance) class(process_instance_t), intent(inout) :: instance end subroutine process_instance_reset_core_kinematics <>= module subroutine process_instance_reset_core_kinematics (instance) class(process_instance_t), intent(inout) :: instance integer :: i if (instance%evaluation_status >= STAT_PASSED_CUTS) then do i = 1, size (instance%term) associate (term => instance%term(i)) if (term%active .and. term%passed) then if (allocated (term%core_state)) & call term%core_state%reset_new_kinematics () end if end associate end do end if end subroutine process_instance_reset_core_kinematics @ %def process_instance_reset_core_kinematics @ Sixth step of process evaluation: evaluate the matrix elements, and compute the trace (summed over quantum numbers) for all terms. Finally, sum up the terms, iterating over all active process components. <>= procedure :: evaluate_trace => process_instance_evaluate_trace <>= module subroutine process_instance_evaluate_trace (instance, recover) class(process_instance_t), intent(inout) :: instance logical, intent(in), optional :: recover end subroutine process_instance_evaluate_trace <>= module subroutine process_instance_evaluate_trace (instance, recover) class(process_instance_t), intent(inout) :: instance logical, intent(in), optional :: recover class(prc_core_t), pointer :: core => null () integer :: i, i_real_fin, i_core, i_qn, i_flv real(default) :: alpha_s, alpha_qed class(prc_core_t), pointer :: core_sub => null () class(model_data_t), pointer :: model => null () logical :: has_pdfs if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "process_instance_evaluate_trace") has_pdfs = instance%process%pcm_contains_pdfs () instance%sqme = zero call instance%reset_matrix_elements () if (instance%evaluation_status >= STAT_PASSED_CUTS) then do i = 1, size (instance%term) associate (term => instance%term(i), kin => instance%kin(i)) if (term%active .and. term%passed) then core => instance%process%get_core_term (i) select type (pcm => instance%process%get_pcm_ptr ()) class is (pcm_nlo_t) i_core = pcm%get_i_core (pcm%i_sub) core_sub => instance%process%get_core_ptr (i_core) end select call term%evaluate_interaction (core, kin) call term%evaluate_trace (kin) i_real_fin = instance%process%get_associated_real_fin (1) if (instance%process%uses_real_partition ()) & call term%apply_real_partition (kin) if (term%config%i_component /= i_real_fin) then if (term%nlo_type == BORN) then do i_flv = 1, term%connected%trace%get_qn_index_n_flv () i_qn = term%connected%trace%get_qn_index (i_flv, i_sub = 0) if (.not. term%passed_array(i_flv)) then call term%connected%trace%set_matrix_element & (i_qn, cmplx (zero, zero, default)) end if end do end if if ((term%nlo_type == NLO_REAL .and. kin%emitter < 0) & .or. term%nlo_type == NLO_MISMATCH & .or. term%nlo_type == NLO_DGLAP) & call term%set_born_sqmes (core) if (term%is_subtraction () .or. & term%nlo_type == NLO_DGLAP) & call term%set_sf_factors (kin, has_pdfs) if (term%nlo_type > BORN) then if (.not. (term%nlo_type == NLO_REAL .and. & kin%emitter >= 0)) then select type (pcm => term%pcm) type is (pcm_nlo_t) if (char (pcm%settings%nlo_correction_type) == "QCD" .or. & char (pcm%settings%nlo_correction_type) == "Full") & call term%evaluate_color_correlations (core_sub) if (char (pcm%settings%nlo_correction_type) == "EW" .or. & char (pcm%settings%nlo_correction_type) == "Full") then call term%evaluate_charge_correlations (core_sub) select type (pcm => term%pcm) type is (pcm_nlo_t) associate (reg_data => pcm%region_data) if (reg_data%alphas_power > 0) & call term%evaluate_color_correlations (core_sub) end associate end select end if end select end if if (term%is_subtraction ()) then call term%evaluate_spin_correlations (core_sub) end if end if alpha_s = core%get_alpha_s (term%core_state) alpha_qed = core%get_alpha_qed (term%core_state) if (term%nlo_type > BORN) then select type (pcm => term%pcm) type is (pcm_nlo_t) if (alpha_qed == -1 .and. (& char (pcm%settings%nlo_correction_type) == "EW" .or. & char (pcm%settings%nlo_correction_type) == "Full")) then call msg_bug("Attempting to compute EW corrections with alpha_qed = -1") end if end select end if if (present (recover)) then if (recover) return end if select case (term%nlo_type) case (NLO_REAL) call term%apply_fks (kin, alpha_s, alpha_qed) case (NLO_VIRTUAL) call term%evaluate_sqme_virt (alpha_s, alpha_qed) case (NLO_MISMATCH) call term%evaluate_sqme_mismatch (alpha_s) case (NLO_DGLAP) call term%evaluate_sqme_dglap (alpha_s, alpha_qed) end select end if end if core_sub => null () instance%sqme = instance%sqme + real (sum (& term%connected%trace%get_matrix_element () * & term%weight)) end associate end do core => null () if (instance%pcm_work%is_valid ()) then instance%evaluation_status = STAT_EVALUATED_TRACE else instance%evaluation_status = STAT_FAILED_KINEMATICS end if else !!! Failed kinematics or failed cuts: set sqme to zero instance%sqme = zero end if end subroutine process_instance_evaluate_trace @ %def process_instance_evaluate_trace <>= procedure :: set_born_sqmes => term_instance_set_born_sqmes <>= module subroutine term_instance_set_born_sqmes (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(in) :: core end subroutine term_instance_set_born_sqmes <>= module subroutine term_instance_set_born_sqmes (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(in) :: core integer :: i_flv, ii_flv real(default) :: sqme select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) do i_flv = 1, term%connected%trace%get_qn_index_n_flv () ii_flv = term%connected%trace%get_qn_index (i_flv, i_sub = 0) if (term%passed_array (i_flv) .or. .not. term%passed) then sqme = real (term%connected%trace%get_matrix_element (ii_flv)) else sqme = zero end if select case (term%nlo_type) case (NLO_REAL) pcm_work%real_sub%sqme_born(i_flv) = sqme case (NLO_MISMATCH) pcm_work%soft_mismatch%sqme_born(i_flv) = sqme case (NLO_DGLAP) pcm_work%dglap_remnant%sqme_born(i_flv) = sqme end select end do end select end subroutine term_instance_set_born_sqmes @ %def term_instance_set_born_sqmes @ Calculates and then saves the ratio of the value of the (rescaled) real structure function chain of each ISR alpha region over the value of the corresponding underlying born flavor structure. In the case of emitter 0 we also need the rescaled ratio for emitter 1 and 2 in that region for the (soft-)collinear limits. If the emitter is 1 or 2 in some cases, e. g. for EW corrections where a photon in the proton is required, there can be the possibility of soft radiation off the initial state. For that purpose the unrescaled ratio is needed and as a default we always save these numbers in [[sf_factors(:,0)]]. Although this procedure is implying functionality for general structure functions, it should be reviewed for anything else besides PDFs, as there might be complications in the details. The general idea of getting the ratio in this way should hold up in these cases as well, however. <>= procedure :: set_sf_factors => term_instance_set_sf_factors <>= module subroutine term_instance_set_sf_factors (term, kin, has_pdfs) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin logical, intent(in) :: has_pdfs end subroutine term_instance_set_sf_factors <>= module subroutine term_instance_set_sf_factors (term, kin, has_pdfs) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin logical, intent(in) :: has_pdfs type(interaction_t), pointer :: sf_chain_int real(default) :: factor_born, factor_real integer :: n_in, alr, em integer :: i_born, i_real select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) if (.not. has_pdfs) then pcm_work%real_sub%sf_factors = one return end if select type (pcm => term%pcm) type is (pcm_nlo_t) sf_chain_int => kin%sf_chain%get_out_int_ptr () associate (reg_data => pcm%region_data) n_in = reg_data%get_n_in () do alr = 1, reg_data%n_regions em = reg_data%regions(alr)%emitter if (em <= n_in) then i_born = reg_data%regions(alr)%uborn_index i_real = reg_data%regions(alr)%real_index factor_born = sf_chain_int%get_matrix_element & (sf_chain_int%get_sf_qn_index_born (i_born, i_sub = 0)) factor_real = sf_chain_int%get_matrix_element & (sf_chain_int%get_sf_qn_index_real (i_real, i_sub = em)) call set_factor (pcm_work, alr, em, factor_born, factor_real) if (em == 0) then do em = 1, 2 factor_real = sf_chain_int%get_matrix_element & (sf_chain_int%get_sf_qn_index_real (i_real, i_sub = em)) call set_factor (pcm_work, alr, em, factor_born, factor_real) end do else factor_real = sf_chain_int%get_matrix_element & (sf_chain_int%get_sf_qn_index_real (i_real, i_sub = 0)) call set_factor (pcm_work, alr, 0, factor_born, factor_real) end if end if end do end associate end select end select contains subroutine set_factor (pcm_work, alr, em, factor_born, factor_real) type(pcm_nlo_workspace_t), intent(inout), target :: pcm_work integer, intent(in) :: alr, em real(default), intent(in) :: factor_born, factor_real real(default) :: factor if (any (vanishes ([factor_real, factor_born], tiny(1._default), tiny(1._default)))) then factor = zero else factor = factor_real / factor_born end if select case (term%nlo_type) case (NLO_REAL) pcm_work%real_sub%sf_factors(alr, em) = factor case (NLO_DGLAP) pcm_work%dglap_remnant%sf_factors(alr, em) = factor end select end subroutine end subroutine term_instance_set_sf_factors @ %def term_instance_set_sf_factors @ <>= procedure :: apply_real_partition => process_instance_apply_real_partition <>= module subroutine process_instance_apply_real_partition (instance) class(process_instance_t), intent(inout) :: instance end subroutine process_instance_apply_real_partition <>= module subroutine process_instance_apply_real_partition (instance) class(process_instance_t), intent(inout) :: instance integer :: i_component, i_term integer, dimension(:), allocatable :: i_terms associate (process => instance%process) i_component = process%get_first_real_component () if (process%component_is_selected (i_component) .and. & process%get_component_nlo_type (i_component) == NLO_REAL) then allocate (i_terms & (size (process%get_component_i_terms (i_component)))) i_terms = process%get_component_i_terms (i_component) do i_term = 1, size (i_terms) call instance%term(i_terms(i_term))%apply_real_partition ( & instance%kin(i_terms(i_term))) end do end if if (allocated (i_terms)) deallocate (i_terms) end associate end subroutine process_instance_apply_real_partition @ %def process_instance_apply_real_partition @ <>= procedure :: set_i_mci_to_real_component => & process_instance_set_i_mci_to_real_component <>= module subroutine process_instance_set_i_mci_to_real_component (instance) class(process_instance_t), intent(inout) :: instance end subroutine process_instance_set_i_mci_to_real_component <>= module subroutine process_instance_set_i_mci_to_real_component (instance) class(process_instance_t), intent(inout) :: instance integer :: i_mci, i_component type(process_component_t), pointer :: component => null () select type (pcm_work => instance%pcm_work) type is (pcm_nlo_workspace_t) if (allocated (pcm_work%i_mci_to_real_component)) then call msg_warning & ("i_mci_to_real_component already allocated - replace it") deallocate (pcm_work%i_mci_to_real_component) end if allocate (pcm_work%i_mci_to_real_component (size (instance%mci_work))) do i_mci = 1, size (instance%mci_work) do i_component = 1, instance%process%get_n_components () component => instance%process%get_component_ptr (i_component) if (component%i_mci /= i_mci) cycle select case (component%component_type) case (COMP_MASTER, COMP_REAL) pcm_work%i_mci_to_real_component (i_mci) = & component%config%get_associated_real () case (COMP_REAL_FIN) pcm_work%i_mci_to_real_component (i_mci) = & component%config%get_associated_real_fin () case (COMP_REAL_SING) pcm_work%i_mci_to_real_component (i_mci) = & component%config%get_associated_real_sing () end select end do end do component => null () end select end subroutine process_instance_set_i_mci_to_real_component @ %def process_instance_set_i_mci_to_real_component @ Final step of process evaluation: evaluate the matrix elements, and compute the trace (summed over quantum numbers) for all terms. Finally, sum up the terms, iterating over all active process components. If [[weight]] is provided, we already know the kinematical event weight (the MCI weight which depends on the kinematics sampling algorithm, but not on the matrix element), so we do not need to take it from the MCI record. <>= procedure :: evaluate_event_data => process_instance_evaluate_event_data <>= module subroutine process_instance_evaluate_event_data (instance, weight) class(process_instance_t), intent(inout) :: instance real(default), intent(in), optional :: weight end subroutine process_instance_evaluate_event_data <>= module subroutine process_instance_evaluate_event_data (instance, weight) class(process_instance_t), intent(inout) :: instance real(default), intent(in), optional :: weight integer :: i if (instance%evaluation_status >= STAT_EVALUATED_TRACE) then do i = 1, size (instance%term) associate (term => instance%term(i)) if (term%active) then call term%evaluate_event_data () end if end associate end do if (present (weight)) then instance%weight = weight else instance%weight = & instance%mci_work(instance%i_mci)%mci%get_event_weight () instance%excess = & instance%mci_work(instance%i_mci)%mci%get_event_excess () end if instance%n_dropped = & instance%mci_work(instance%i_mci)%mci%get_n_event_dropped () instance%evaluation_status = STAT_EVENT_COMPLETE else !!! failed kinematics etc.: set weight to zero instance%weight = zero !!! Maybe we want to process and keep the event nevertheless if (instance%keep_failed_events ()) then do i = 1, size (instance%term) associate (term => instance%term(i)) if (term%active) then call term%evaluate_event_data () end if end associate end do ! do i = 1, size (instance%term) ! instance%term(i)%fac_scale = zero ! end do instance%evaluation_status = STAT_EVENT_COMPLETE end if end if end subroutine process_instance_evaluate_event_data @ %def process_instance_evaluate_event_data @ Computes the real-emission matrix element for externally supplied momenta for the term instance with index [[i_term]] and a phase space point set with index [[i_phs]]. In addition, for the real emission, each term instance corresponds to one emitter. There is the possibility to supply an external $\alpha_s$ as well as an external scale to override the scale set in the -Sindarin, e.g. for POWHEG. +Sindarin, e.g. for POWHEG matching. <>= procedure :: compute_sqme_rad => process_instance_compute_sqme_rad <>= module subroutine process_instance_compute_sqme_rad (instance, & i_term, i_phs, is_subtraction, alpha_s_external, scale_forced) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term, i_phs logical, intent(in) :: is_subtraction real(default), intent(in), optional :: alpha_s_external real(default), intent(in), allocatable, optional :: scale_forced end subroutine process_instance_compute_sqme_rad <>= module subroutine process_instance_compute_sqme_rad (instance, & i_term, i_phs, is_subtraction, alpha_s_external, scale_forced) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term, i_phs logical, intent(in) :: is_subtraction real(default), intent(in), optional :: alpha_s_external real(default), intent(in), allocatable, optional :: scale_forced class(prc_core_t), pointer :: core integer :: i_real_fin logical :: has_pdfs has_pdfs = instance%process%pcm_contains_pdfs () if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "process_instance_compute_sqme_rad") select type (pcm_work => instance%pcm_work) type is (pcm_nlo_workspace_t) associate (term => instance%term(i_term), kin => instance%kin(i_term)) core => instance%process%get_core_term (i_term) if (is_subtraction) then call pcm_work%set_subtraction_event () else call pcm_work%set_radiation_event () end if call term%int_hard%set_momenta (pcm_work%get_momenta & (term%pcm, i_phs = i_phs, born_phsp = is_subtraction)) if (allocated (term%core_state)) & call term%core_state%reset_new_kinematics () if (present (alpha_s_external)) then call term%set_alpha_qcd_forced (alpha_s_external) end if call term%compute_eff_kinematics () call term%evaluate_expressions & (instance%process%get_beam_config (), scale_forced) call term%evaluate_interaction (core, kin) call term%evaluate_trace (kin) if (term%is_subtraction ()) then call term%set_sf_factors (kin, has_pdfs) select type (pcm => instance%pcm) type is (pcm_nlo_t) if (char (pcm%settings%nlo_correction_type) == "QCD" .or. & char (pcm%settings%nlo_correction_type) == "Full") & call term%evaluate_color_correlations (core) if (char (pcm%settings%nlo_correction_type) == "EW" .or. & char (pcm%settings%nlo_correction_type) == "Full") & call term%evaluate_charge_correlations (core) end select call term%evaluate_spin_correlations (core) end if i_real_fin = instance%process%get_associated_real_fin (1) if (term%config%i_component /= i_real_fin) & call term%apply_fks (kin, core%get_alpha_s (term%core_state), & core%get_alpha_qed (term%core_state)) if (instance%process%uses_real_partition ()) & call instance%apply_real_partition () end associate end select core => null () end subroutine process_instance_compute_sqme_rad @ %def process_instance_compute_sqme_rad @ For unweighted event generation, we should reset the reported event weight to unity (signed) or zero. The latter case is appropriate for an event which failed for whatever reason. <>= procedure :: normalize_weight => process_instance_normalize_weight <>= module subroutine process_instance_normalize_weight (instance) class(process_instance_t), intent(inout) :: instance end subroutine process_instance_normalize_weight <>= module subroutine process_instance_normalize_weight (instance) class(process_instance_t), intent(inout) :: instance if (.not. vanishes (instance%weight)) then instance%weight = sign (1._default, instance%weight) end if end subroutine process_instance_normalize_weight @ %def process_instance_normalize_weight @ This is a convenience routine that performs the computations of the steps 1 to 5 in a single step. The arguments are the input for [[set_mcpar]]. After this, the evaluation status should be either [[STAT_FAILED_KINEMATICS]], [[STAT_FAILED_CUTS]] or [[STAT_EVALUATED_TRACE]]. Before calling this, we should call [[choose_mci]]. <>= procedure :: evaluate_sqme => process_instance_evaluate_sqme <>= module subroutine process_instance_evaluate_sqme (instance, channel, x) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: channel real(default), dimension(:), intent(in) :: x end subroutine process_instance_evaluate_sqme <>= module subroutine process_instance_evaluate_sqme (instance, channel, x) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: channel real(default), dimension(:), intent(in) :: x call instance%reset () call instance%set_mcpar (x) call instance%select_channel (channel) call instance%compute_seed_kinematics () call instance%compute_hard_kinematics () call instance%compute_eff_kinematics () call instance%evaluate_expressions () call instance%compute_other_channels () call instance%evaluate_trace () end subroutine process_instance_evaluate_sqme @ %def process_instance_evaluate_sqme @ This is the inverse. Assuming that the final trace evaluator contains a valid momentum configuration, recover kinematics and recalculate the matrix elements and their trace. To be precise, we first recover kinematics for the given term and associated component, then recalculate from that all other terms and active components. The [[channel]] is not really required to obtain the matrix element, but it allows us to reconstruct the exact MC parameter set that corresponds to the given phase space point. Before calling this, we should call [[choose_mci]]. <>= procedure :: recover => process_instance_recover <>= module subroutine process_instance_recover & (instance, channel, i_term, update_sqme, recover_phs, scale_forced) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: channel integer, intent(in) :: i_term logical, intent(in) :: update_sqme logical, intent(in) :: recover_phs real(default), intent(in), allocatable, optional :: scale_forced end subroutine process_instance_recover <>= module subroutine process_instance_recover & (instance, channel, i_term, update_sqme, recover_phs, scale_forced) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: channel integer, intent(in) :: i_term logical, intent(in) :: update_sqme logical, intent(in) :: recover_phs real(default), intent(in), allocatable, optional :: scale_forced logical :: skip_phs, recover call instance%activate () instance%evaluation_status = STAT_EFF_KINEMATICS call instance%recover_hard_kinematics (i_term) call instance%recover_seed_kinematics (i_term) call instance%select_channel (channel) recover = instance%pcm_work%is_nlo () if (recover_phs) then call instance%recover_mcpar (i_term) call instance%recover_beam_momenta (i_term) call instance%compute_seed_kinematics & (recover = recover, skip_term = i_term) call instance%compute_hard_kinematics & (recover = recover, skip_term = i_term) call instance%compute_eff_kinematics (i_term) call instance%compute_other_channels (i_term) else call instance%recover_sfchain (i_term) end if call instance%evaluate_expressions (scale_forced) if (update_sqme) then call instance%reset_core_kinematics () call instance%evaluate_trace (recover) end if end subroutine process_instance_recover @ %def process_instance_recover @ The [[evaluate]] method is required by the [[sampler_t]] base type of which the process instance is an extension. The requirement is that after the process instance is evaluated, the integrand, the selected channel, the $x$ array, and the $f$ Jacobian array are exposed by the [[sampler_t]] object. We allow for the additional [[hook]] to be called, if associated, for outlying object to access information from the current state of the [[sampler]]. <>= procedure :: evaluate => process_instance_evaluate <>= module subroutine process_instance_evaluate (sampler, c, x_in, val, x, f) class(process_instance_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f end subroutine process_instance_evaluate <>= module subroutine process_instance_evaluate (sampler, c, x_in, val, x, f) class(process_instance_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%evaluate_sqme (c, x_in) if (sampler%is_valid ()) then call sampler%fetch (val, x, f) end if call sampler%record_call () call sampler%evaluate_after_hook () end subroutine process_instance_evaluate @ %def process_instance_evaluate @ The phase-space point is valid if the event has valid kinematics and has passed the cuts. <>= procedure :: is_valid => process_instance_is_valid <>= module function process_instance_is_valid (sampler) result (valid) class(process_instance_t), intent(in) :: sampler logical :: valid end function process_instance_is_valid <>= module function process_instance_is_valid (sampler) result (valid) class(process_instance_t), intent(in) :: sampler logical :: valid valid = sampler%evaluation_status >= STAT_PASSED_CUTS end function process_instance_is_valid @ %def process_instance_is_valid @ Add a [[process_instance_hook]] object.. <>= procedure :: append_after_hook => process_instance_append_after_hook <>= module subroutine process_instance_append_after_hook (sampler, new_hook) class(process_instance_t), intent(inout), target :: sampler class(process_instance_hook_t), intent(inout), target :: new_hook end subroutine process_instance_append_after_hook <>= module subroutine process_instance_append_after_hook (sampler, new_hook) class(process_instance_t), intent(inout), target :: sampler class(process_instance_hook_t), intent(inout), target :: new_hook class(process_instance_hook_t), pointer :: last if (associated (new_hook%next)) then call msg_bug ("process_instance_append_after_hook: " // & "reuse of SAME hook object is forbidden.") end if if (associated (sampler%hook)) then last => sampler%hook do while (associated (last%next)) last => last%next end do last%next => new_hook else sampler%hook => new_hook end if end subroutine process_instance_append_after_hook @ %def process_instance_append_after_evaluate_hook @ Evaluate the after hook as first in, last out. <>= procedure :: evaluate_after_hook => process_instance_evaluate_after_hook <>= module subroutine process_instance_evaluate_after_hook (sampler) class(process_instance_t), intent(in) :: sampler end subroutine process_instance_evaluate_after_hook <>= module subroutine process_instance_evaluate_after_hook (sampler) class(process_instance_t), intent(in) :: sampler class(process_instance_hook_t), pointer :: current current => sampler%hook do while (associated(current)) call current%evaluate (sampler) current => current%next end do end subroutine process_instance_evaluate_after_hook @ %def process_instance_evaluate_after_hook @ The [[rebuild]] method should rebuild the kinematics section out of the [[x_in]] parameter set. The integrand value [[val]] should not be computed, but is provided as input. <>= procedure :: rebuild => process_instance_rebuild <>= module subroutine process_instance_rebuild (sampler, c, x_in, val, x, f) class(process_instance_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f end subroutine process_instance_rebuild <>= module subroutine process_instance_rebuild (sampler, c, x_in, val, x, f) class(process_instance_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call msg_bug ("process_instance_rebuild not implemented yet") x = 0 f = 0 end subroutine process_instance_rebuild @ %def process_instance_rebuild @ This is another method required by the [[sampler_t]] base type: fetch the data that are relevant for the MCI record. <>= procedure :: fetch => process_instance_fetch <>= module subroutine process_instance_fetch (sampler, val, x, f) class(process_instance_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f end subroutine process_instance_fetch <>= module subroutine process_instance_fetch (sampler, val, x, f) class(process_instance_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f integer, dimension(:), allocatable :: i_terms integer :: i, i_term_base, cc integer :: n_channel val = 0 associate (process => sampler%process) FIND_COMPONENT: do i = 1, process%get_n_components () if (sampler%process%component_is_selected (i)) then allocate (i_terms (size (process%get_component_i_terms (i)))) i_terms = process%get_component_i_terms (i) i_term_base = i_terms(1) associate (k => sampler%kin(i_term_base)) n_channel = k%n_channel do cc = 1, n_channel call k%get_mcpar (cc, x(:,cc)) end do f = k%f val = sampler%sqme * k%phs_factor end associate if (allocated (i_terms)) deallocate (i_terms) exit FIND_COMPONENT end if end do FIND_COMPONENT end associate end subroutine process_instance_fetch @ %def process_instance_fetch @ Initialize and finalize event generation for the specified MCI entry. <>= procedure :: init_simulation => process_instance_init_simulation procedure :: final_simulation => process_instance_final_simulation <>= module subroutine process_instance_init_simulation (instance, i_mci, & safety_factor, keep_failed_events) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci real(default), intent(in), optional :: safety_factor logical, intent(in), optional :: keep_failed_events end subroutine process_instance_init_simulation module subroutine process_instance_final_simulation (instance, i_mci) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci end subroutine process_instance_final_simulation <>= module subroutine process_instance_init_simulation (instance, i_mci, & safety_factor, keep_failed_events) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci real(default), intent(in), optional :: safety_factor logical, intent(in), optional :: keep_failed_events call instance%mci_work(i_mci)%init_simulation & (safety_factor, keep_failed_events) end subroutine process_instance_init_simulation module subroutine process_instance_final_simulation (instance, i_mci) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci call instance%mci_work(i_mci)%final_simulation () end subroutine process_instance_final_simulation @ %def process_instance_init_simulation @ %def process_instance_final_simulation @ \subsubsection{Accessing the process instance} Once the seed kinematics is complete, we can retrieve the MC input parameters for all channels, not just the seed channel. Note: We choose the first active component. This makes sense only if the seed kinematics is identical for all active components. <>= procedure :: get_mcpar => process_instance_get_mcpar <>= module subroutine process_instance_get_mcpar (instance, channel, x) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: channel real(default), dimension(:), intent(out) :: x end subroutine process_instance_get_mcpar <>= module subroutine process_instance_get_mcpar (instance, channel, x) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: channel real(default), dimension(:), intent(out) :: x integer :: i if (instance%evaluation_status >= STAT_SEED_KINEMATICS) then do i = 1, size (instance%term) if (instance%term(i)%active) then call instance%kin(i)%get_mcpar (channel, x) return end if end do call msg_bug ("Process instance: get_mcpar: no active channels") else call msg_bug ("Process instance: get_mcpar: no seed kinematics") end if end subroutine process_instance_get_mcpar @ %def process_instance_get_mcpar @ Return true if the [[sqme]] value is known. This also implies that the event is kinematically valid and has passed all cuts. <>= procedure :: has_evaluated_trace => process_instance_has_evaluated_trace <>= module function process_instance_has_evaluated_trace & (instance) result (flag) class(process_instance_t), intent(in) :: instance logical :: flag end function process_instance_has_evaluated_trace <>= module function process_instance_has_evaluated_trace (instance) result (flag) class(process_instance_t), intent(in) :: instance logical :: flag flag = instance%evaluation_status >= STAT_EVALUATED_TRACE end function process_instance_has_evaluated_trace @ %def process_instance_has_evaluated_trace @ Return true if the event is complete. In particular, the event must be kinematically valid, passed all cuts, and the event data have been computed. <>= procedure :: is_complete_event => process_instance_is_complete_event <>= module function process_instance_is_complete_event (instance) result (flag) class(process_instance_t), intent(in) :: instance logical :: flag end function process_instance_is_complete_event <>= module function process_instance_is_complete_event (instance) result (flag) class(process_instance_t), intent(in) :: instance logical :: flag flag = instance%evaluation_status >= STAT_EVENT_COMPLETE end function process_instance_is_complete_event @ %def process_instance_is_complete_event @ Select the term for the process instance that will provide the basic event record (used in [[evt_trivial_make_particle_set]]). It might be necessary to write out additional events corresponding to other terms (done in [[evt_nlo]]). <>= procedure :: select_i_term => process_instance_select_i_term <>= module function process_instance_select_i_term (instance) result (i_term) integer :: i_term class(process_instance_t), intent(in) :: instance end function process_instance_select_i_term <>= module function process_instance_select_i_term (instance) result (i_term) integer :: i_term class(process_instance_t), intent(in) :: instance integer :: i_mci i_mci = instance%i_mci i_term = instance%process%select_i_term (i_mci) end function process_instance_select_i_term @ %def process_instance_select_i_term @ Return pointer to the master beam interaction. <>= procedure :: get_beam_int_ptr => process_instance_get_beam_int_ptr <>= module function process_instance_get_beam_int_ptr (instance) result (ptr) class(process_instance_t), intent(in), target :: instance type(interaction_t), pointer :: ptr end function process_instance_get_beam_int_ptr <>= module function process_instance_get_beam_int_ptr (instance) result (ptr) class(process_instance_t), intent(in), target :: instance type(interaction_t), pointer :: ptr ptr => instance%sf_chain%get_beam_int_ptr () end function process_instance_get_beam_int_ptr @ %def process_instance_get_beam_int_ptr @ Return pointers to the matrix and flows interactions, given a term index. <>= procedure :: get_trace_int_ptr => process_instance_get_trace_int_ptr procedure :: get_matrix_int_ptr => process_instance_get_matrix_int_ptr procedure :: get_flows_int_ptr => process_instance_get_flows_int_ptr <>= module function process_instance_get_trace_int_ptr & (instance, i_term) result (ptr) class(process_instance_t), intent(in), target :: instance integer, intent(in) :: i_term type(interaction_t), pointer :: ptr end function process_instance_get_trace_int_ptr module function process_instance_get_matrix_int_ptr & (instance, i_term) result (ptr) class(process_instance_t), intent(in), target :: instance integer, intent(in) :: i_term type(interaction_t), pointer :: ptr end function process_instance_get_matrix_int_ptr module function process_instance_get_flows_int_ptr & (instance, i_term) result (ptr) class(process_instance_t), intent(in), target :: instance integer, intent(in) :: i_term type(interaction_t), pointer :: ptr end function process_instance_get_flows_int_ptr <>= module function process_instance_get_trace_int_ptr & (instance, i_term) result (ptr) class(process_instance_t), intent(in), target :: instance integer, intent(in) :: i_term type(interaction_t), pointer :: ptr ptr => instance%term(i_term)%connected%get_trace_int_ptr () end function process_instance_get_trace_int_ptr module function process_instance_get_matrix_int_ptr & (instance, i_term) result (ptr) class(process_instance_t), intent(in), target :: instance integer, intent(in) :: i_term type(interaction_t), pointer :: ptr ptr => instance%term(i_term)%connected%get_matrix_int_ptr () end function process_instance_get_matrix_int_ptr module function process_instance_get_flows_int_ptr & (instance, i_term) result (ptr) class(process_instance_t), intent(in), target :: instance integer, intent(in) :: i_term type(interaction_t), pointer :: ptr ptr => instance%term(i_term)%connected%get_flows_int_ptr () end function process_instance_get_flows_int_ptr @ %def process_instance_get_trace_int_ptr @ %def process_instance_get_matrix_int_ptr @ %def process_instance_get_flows_int_ptr @ Return the complete account of flavor combinations in the underlying interaction object, including beams, radiation, and hard interaction. <>= procedure :: get_state_flv => process_instance_get_state_flv <>= module function process_instance_get_state_flv & (instance, i_term) result (state_flv) class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term type(state_flv_content_t) :: state_flv end function process_instance_get_state_flv <>= module function process_instance_get_state_flv & (instance, i_term) result (state_flv) class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term type(state_flv_content_t) :: state_flv state_flv = instance%term(i_term)%connected%get_state_flv () end function process_instance_get_state_flv @ %def process_instance_get_state_flv @ Return pointers to the parton states of a selected term. <>= procedure :: get_isolated_state_ptr => & process_instance_get_isolated_state_ptr procedure :: get_connected_state_ptr => & process_instance_get_connected_state_ptr <>= module function process_instance_get_isolated_state_ptr & (instance, i_term) result (ptr) class(process_instance_t), intent(in), target :: instance integer, intent(in) :: i_term type(isolated_state_t), pointer :: ptr end function process_instance_get_isolated_state_ptr module function process_instance_get_connected_state_ptr & (instance, i_term) result (ptr) class(process_instance_t), intent(in), target :: instance integer, intent(in) :: i_term type(connected_state_t), pointer :: ptr end function process_instance_get_connected_state_ptr <>= module function process_instance_get_isolated_state_ptr & (instance, i_term) result (ptr) class(process_instance_t), intent(in), target :: instance integer, intent(in) :: i_term type(isolated_state_t), pointer :: ptr ptr => instance%term(i_term)%isolated end function process_instance_get_isolated_state_ptr module function process_instance_get_connected_state_ptr & (instance, i_term) result (ptr) class(process_instance_t), intent(in), target :: instance integer, intent(in) :: i_term type(connected_state_t), pointer :: ptr ptr => instance%term(i_term)%connected end function process_instance_get_connected_state_ptr @ %def process_instance_get_isolated_state_ptr @ %def process_instance_get_connected_state_ptr @ Return the indices of the beam particles and incoming partons within the currently active state matrix, respectively. <>= procedure :: get_beam_index => process_instance_get_beam_index procedure :: get_in_index => process_instance_get_in_index <>= module subroutine process_instance_get_beam_index (instance, i_term, i_beam) class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term integer, dimension(:), intent(out) :: i_beam end subroutine process_instance_get_beam_index module subroutine process_instance_get_in_index (instance, i_term, i_in) class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term integer, dimension(:), intent(out) :: i_in end subroutine process_instance_get_in_index <>= module subroutine process_instance_get_beam_index (instance, i_term, i_beam) class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term integer, dimension(:), intent(out) :: i_beam call instance%term(i_term)%connected%get_beam_index (i_beam) end subroutine process_instance_get_beam_index module subroutine process_instance_get_in_index (instance, i_term, i_in) class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term integer, dimension(:), intent(out) :: i_in call instance%term(i_term)%connected%get_in_index (i_in) end subroutine process_instance_get_in_index @ %def process_instance_get_beam_index @ %def process_instance_get_in_index @ Return squared matrix element and event weight, and event weight excess where applicable. [[n_dropped]] is a number that can be nonzero when a weighted event has been generated, dropping events with zero weight (failed cuts) on the fly. If [[i_term]] is provided for [[get_sqme]], we take the first matrix element as we also set the first matrix element with [[set_only_matrix_element]] when computing the real, the dglap or the virtual contribution. <>= procedure :: get_sqme => process_instance_get_sqme procedure :: get_weight => process_instance_get_weight procedure :: get_excess => process_instance_get_excess procedure :: get_n_dropped => process_instance_get_n_dropped <>= module function process_instance_get_sqme (instance, i_term) result (sqme) real(default) :: sqme class(process_instance_t), intent(in) :: instance integer, intent(in), optional :: i_term end function process_instance_get_sqme module function process_instance_get_weight (instance) result (weight) real(default) :: weight class(process_instance_t), intent(in) :: instance end function process_instance_get_weight module function process_instance_get_excess (instance) result (excess) real(default) :: excess class(process_instance_t), intent(in) :: instance end function process_instance_get_excess module function process_instance_get_n_dropped (instance) result (n_dropped) integer :: n_dropped class(process_instance_t), intent(in) :: instance end function process_instance_get_n_dropped <>= module function process_instance_get_sqme (instance, i_term) result (sqme) real(default) :: sqme class(process_instance_t), intent(in) :: instance integer, intent(in), optional :: i_term if (instance%evaluation_status >= STAT_EVALUATED_TRACE) then if (present (i_term)) then sqme = instance%term(i_term)%connected%trace%get_matrix_element (1) else sqme = instance%sqme end if else sqme = 0 end if end function process_instance_get_sqme module function process_instance_get_weight (instance) result (weight) real(default) :: weight class(process_instance_t), intent(in) :: instance if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then weight = instance%weight else weight = 0 end if end function process_instance_get_weight module function process_instance_get_excess (instance) result (excess) real(default) :: excess class(process_instance_t), intent(in) :: instance if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then excess = instance%excess else excess = 0 end if end function process_instance_get_excess module function process_instance_get_n_dropped (instance) result (n_dropped) integer :: n_dropped class(process_instance_t), intent(in) :: instance if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then n_dropped = instance%n_dropped else n_dropped = 0 end if end function process_instance_get_n_dropped @ %def process_instance_get_sqme @ %def process_instance_get_weight @ %def process_instance_get_excess @ %def process_instance_get_n_dropped @ Return the currently selected MCI channel. <>= procedure :: get_channel => process_instance_get_channel <>= module function process_instance_get_channel (instance) result (channel) integer :: channel class(process_instance_t), intent(in) :: instance end function process_instance_get_channel <>= module function process_instance_get_channel (instance) result (channel) integer :: channel class(process_instance_t), intent(in) :: instance channel = instance%selected_channel end function process_instance_get_channel @ %def process_instance_get_channel @ <>= procedure :: set_fac_scale => process_instance_set_fac_scale <>= module subroutine process_instance_set_fac_scale (instance, fac_scale) class(process_instance_t), intent(inout) :: instance real(default), intent(in) :: fac_scale end subroutine process_instance_set_fac_scale <>= module subroutine process_instance_set_fac_scale (instance, fac_scale) class(process_instance_t), intent(inout) :: instance real(default), intent(in) :: fac_scale integer :: i_term i_term = 1 call instance%term(i_term)%set_fac_scale (fac_scale) end subroutine process_instance_set_fac_scale @ %def process_instance_set_fac_scale @ Return factorization scale and strong coupling. We have to select a term instance. <>= procedure :: get_fac_scale => process_instance_get_fac_scale procedure :: get_alpha_s => process_instance_get_alpha_s <>= module function process_instance_get_fac_scale & (instance, i_term) result (fac_scale) class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term real(default) :: fac_scale end function process_instance_get_fac_scale module function process_instance_get_alpha_s & (instance, i_term) result (alpha_s) real(default) :: alpha_s class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term end function process_instance_get_alpha_s <>= module function process_instance_get_fac_scale & (instance, i_term) result (fac_scale) class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term real(default) :: fac_scale fac_scale = instance%term(i_term)%get_fac_scale () end function process_instance_get_fac_scale module function process_instance_get_alpha_s & (instance, i_term) result (alpha_s) real(default) :: alpha_s class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term class(prc_core_t), pointer :: core => null () core => instance%process%get_core_term (i_term) alpha_s = instance%term(i_term)%get_alpha_s (core) core => null () end function process_instance_get_alpha_s @ %def process_instance_get_fac_scale @ %def process_instance_get_alpha_s @ <>= procedure :: get_qcd => process_instance_get_qcd <>= module function process_instance_get_qcd (process_instance) result (qcd) type(qcd_t) :: qcd class(process_instance_t), intent(in) :: process_instance end function process_instance_get_qcd <>= module function process_instance_get_qcd (process_instance) result (qcd) type(qcd_t) :: qcd class(process_instance_t), intent(in) :: process_instance qcd = process_instance%process%get_qcd () end function process_instance_get_qcd @ %def process_instance_get_qcd @ Counter. <>= procedure :: reset_counter => process_instance_reset_counter procedure :: record_call => process_instance_record_call procedure :: get_counter => process_instance_get_counter <>= module subroutine process_instance_reset_counter (process_instance) class(process_instance_t), intent(inout) :: process_instance end subroutine process_instance_reset_counter module subroutine process_instance_record_call (process_instance) class(process_instance_t), intent(inout) :: process_instance end subroutine process_instance_record_call pure module function process_instance_get_counter & (process_instance) result (counter) class(process_instance_t), intent(in) :: process_instance type(process_counter_t) :: counter end function process_instance_get_counter <>= module subroutine process_instance_reset_counter (process_instance) class(process_instance_t), intent(inout) :: process_instance call process_instance%mci_work(process_instance%i_mci)%reset_counter () end subroutine process_instance_reset_counter module subroutine process_instance_record_call (process_instance) class(process_instance_t), intent(inout) :: process_instance call process_instance%mci_work(process_instance%i_mci)%record_call & (process_instance%evaluation_status) end subroutine process_instance_record_call pure module function process_instance_get_counter & (process_instance) result (counter) class(process_instance_t), intent(in) :: process_instance type(process_counter_t) :: counter counter = process_instance%mci_work(process_instance%i_mci)%get_counter () end function process_instance_get_counter @ %def process_instance_reset_counter @ %def process_instance_record_call @ %def process_instance_get_counter @ Sum up the total number of calls for all MCI records. <>= procedure :: get_actual_calls_total => process_instance_get_actual_calls_total <>= pure module function process_instance_get_actual_calls_total & (process_instance) result (n) class(process_instance_t), intent(in) :: process_instance integer :: n end function process_instance_get_actual_calls_total <>= pure module function process_instance_get_actual_calls_total & (process_instance) result (n) class(process_instance_t), intent(in) :: process_instance integer :: n integer :: i type(process_counter_t) :: counter n = 0 do i = 1, size (process_instance%mci_work) counter = process_instance%mci_work(i)%get_counter () n = n + counter%total end do end function process_instance_get_actual_calls_total @ %def process_instance_get_actual_calls_total @ <>= procedure :: reset_matrix_elements => process_instance_reset_matrix_elements <>= module subroutine process_instance_reset_matrix_elements (instance) class(process_instance_t), intent(inout) :: instance end subroutine process_instance_reset_matrix_elements <>= module subroutine process_instance_reset_matrix_elements (instance) class(process_instance_t), intent(inout) :: instance integer :: i_term do i_term = 1, size (instance%term) call instance%term(i_term)%connected%trace%set_matrix_element & (cmplx (0, 0, default)) call instance%term(i_term)%connected%matrix%set_matrix_element & (cmplx (0, 0, default)) end do end subroutine process_instance_reset_matrix_elements @ %def process_instance_reset_matrix_elements @ <>= procedure :: get_test_phase_space_point & => process_instance_get_test_phase_space_point <>= module subroutine process_instance_get_test_phase_space_point (instance, & i_component, i_core, p) type(vector4_t), dimension(:), allocatable, intent(out) :: p class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_component, i_core end subroutine process_instance_get_test_phase_space_point <>= module subroutine process_instance_get_test_phase_space_point (instance, & i_component, i_core, p) type(vector4_t), dimension(:), allocatable, intent(out) :: p class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_component, i_core real(default), dimension(:), allocatable :: x logical :: success integer :: i_term instance%i_mci = i_component i_term = instance%process%get_i_term (i_core) associate (term => instance%term(i_term), kin => instance%kin(i_term)) allocate (x (instance%mci_work(i_component)%config%n_par)) x = 0.5_default call instance%set_mcpar (x, .true.) call instance%select_channel (1) call term%compute_seed_kinematics & (kin, instance%mci_work(i_component), 1, success) call kin%evaluate_radiation_kinematics & (instance%mci_work(instance%i_mci)%get_x_process ()) call term%compute_hard_kinematics (kin, success = success) allocate (p (size (term%p_hard))) p = term%int_hard%get_momenta () end associate end subroutine process_instance_get_test_phase_space_point @ %def process_instance_get_test_phase_space_point @ <>= procedure :: get_p_hard => process_instance_get_p_hard <>= pure module function process_instance_get_p_hard & (process_instance, i_term) result (p_hard) type(vector4_t), dimension(:), allocatable :: p_hard class(process_instance_t), intent(in) :: process_instance integer, intent(in) :: i_term end function process_instance_get_p_hard <>= pure module function process_instance_get_p_hard & (process_instance, i_term) result (p_hard) type(vector4_t), dimension(:), allocatable :: p_hard class(process_instance_t), intent(in) :: process_instance integer, intent(in) :: i_term allocate (p_hard (size (process_instance%term(i_term)%get_p_hard ()))) p_hard = process_instance%term(i_term)%get_p_hard () end function process_instance_get_p_hard @ %def process_instance_get_p_hard @ <>= procedure :: get_first_active_i_term => & process_instance_get_first_active_i_term <>= module function process_instance_get_first_active_i_term & (instance) result (i_term) integer :: i_term class(process_instance_t), intent(in) :: instance end function process_instance_get_first_active_i_term <>= module function process_instance_get_first_active_i_term & (instance) result (i_term) integer :: i_term class(process_instance_t), intent(in) :: instance integer :: i i_term = 0 do i = 1, size (instance%term) if (instance%term(i)%active) then i_term = i exit end if end do end function process_instance_get_first_active_i_term @ %def process_instance_get_first_active_i_term @ <>= procedure :: get_real_of_mci => process_instance_get_real_of_mci <>= module function process_instance_get_real_of_mci (instance) result (i_real) integer :: i_real class(process_instance_t), intent(in) :: instance end function process_instance_get_real_of_mci <>= module function process_instance_get_real_of_mci (instance) result (i_real) integer :: i_real class(process_instance_t), intent(in) :: instance select type (pcm_work => instance%pcm_work) type is (pcm_nlo_workspace_t) i_real = pcm_work%i_mci_to_real_component (instance%i_mci) end select end function process_instance_get_real_of_mci @ %def process_instance_get_real_of_mci @ <>= procedure :: get_connected_states => process_instance_get_connected_states <>= module function process_instance_get_connected_states & (instance, i_component) result (connected) type(connected_state_t), dimension(:), allocatable :: connected class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_component end function process_instance_get_connected_states <>= module function process_instance_get_connected_states & (instance, i_component) result (connected) type(connected_state_t), dimension(:), allocatable :: connected class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_component connected = instance%process%get_connected_states (i_component, & instance%term(:)%connected) end function process_instance_get_connected_states @ %def process_instance_get_connected_states @ Get the hadronic center-of-mass energy <>= procedure :: get_sqrts => process_instance_get_sqrts <>= module function process_instance_get_sqrts (instance) result (sqrts) class(process_instance_t), intent(in) :: instance real(default) :: sqrts end function process_instance_get_sqrts <>= module function process_instance_get_sqrts (instance) result (sqrts) class(process_instance_t), intent(in) :: instance real(default) :: sqrts sqrts = instance%process%get_sqrts () end function process_instance_get_sqrts @ %def process_instance_get_sqrts @ Get the polarizations <>= procedure :: get_polarization => process_instance_get_polarization <>= module function process_instance_get_polarization (instance) result (pol) class(process_instance_t), intent(in) :: instance real(default), dimension(:), allocatable :: pol end function process_instance_get_polarization <>= module function process_instance_get_polarization (instance) result (pol) class(process_instance_t), intent(in) :: instance real(default), dimension(:), allocatable :: pol pol = instance%process%get_polarization () end function process_instance_get_polarization @ %def process_instance_get_polarization @ Get the beam spectrum <>= procedure :: get_beam_file => process_instance_get_beam_file <>= module function process_instance_get_beam_file (instance) result (file) class(process_instance_t), intent(in) :: instance type(string_t) :: file end function process_instance_get_beam_file <>= module function process_instance_get_beam_file (instance) result (file) class(process_instance_t), intent(in) :: instance type(string_t) :: file file = instance%process%get_beam_file () end function process_instance_get_beam_file @ %def process_instance_get_beam_file @ Get the process name <>= procedure :: get_process_name => process_instance_get_process_name <>= module function process_instance_get_process_name (instance) result (name) class(process_instance_t), intent(in) :: instance type(string_t) :: name end function process_instance_get_process_name <>= module function process_instance_get_process_name (instance) result (name) class(process_instance_t), intent(in) :: instance type(string_t) :: name name = instance%process%get_id () end function process_instance_get_process_name @ %def process_instance_get_process_name @ \subsubsection{Particle sets} Here we provide two procedures that convert the process instance from/to a particle set. The conversion applies to the trace evaluator which has no quantum-number information, thus it involves only the momenta and the parent-child relations. We keep virtual particles. If [[n_incoming]] is provided, the status code of the first [[n_incoming]] particles will be reset to incoming. Otherwise, they would be classified as virtual. Nevertheless, it is possible to reconstruct the complete structure from a particle set. The reconstruction implies a re-evaluation of the structure function and matrix-element codes. The [[i_term]] index is needed for both input and output, to select among different active trace evaluators. In both cases, the [[instance]] object must be properly initialized. NB: The [[recover_beams]] option should be used only when the particle set originates from an external event file, and the user has asked for it. It should be switched off when reading from raw event file. <>= procedure :: get_trace => process_instance_get_trace procedure :: set_trace => process_instance_set_trace <>= module subroutine process_instance_get_trace & (instance, pset, i_term, n_incoming) class(process_instance_t), intent(in), target :: instance type(particle_set_t), intent(out) :: pset integer, intent(in) :: i_term integer, intent(in), optional :: n_incoming end subroutine process_instance_get_trace module subroutine process_instance_set_trace & (instance, pset, i_term, recover_beams, check_match, success) class(process_instance_t), intent(inout), target :: instance type(particle_set_t), intent(in) :: pset integer, intent(in) :: i_term logical, intent(in), optional :: recover_beams, check_match logical, intent(out), optional :: success end subroutine process_instance_set_trace <>= module subroutine process_instance_get_trace & (instance, pset, i_term, n_incoming) class(process_instance_t), intent(in), target :: instance type(particle_set_t), intent(out) :: pset integer, intent(in) :: i_term integer, intent(in), optional :: n_incoming type(interaction_t), pointer :: int logical :: ok int => instance%get_trace_int_ptr (i_term) call pset%init (ok, int, int, FM_IGNORE_HELICITY, & [0._default, 0._default], .false., .true., n_incoming) end subroutine process_instance_get_trace module subroutine process_instance_set_trace & (instance, pset, i_term, recover_beams, check_match, success) class(process_instance_t), intent(inout), target :: instance type(particle_set_t), intent(in) :: pset integer, intent(in) :: i_term logical, intent(in), optional :: recover_beams, check_match logical, intent(out), optional :: success type(interaction_t), pointer :: int integer :: n_in int => instance%get_trace_int_ptr (i_term) n_in = instance%process%get_n_in () call pset%fill_interaction (int, n_in, & recover_beams = recover_beams, & check_match = check_match, & state_flv = instance%get_state_flv (i_term), & success = success) end subroutine process_instance_set_trace @ %def process_instance_get_trace @ %def process_instance_set_trace @ This procedure allows us to override any QCD setting of the WHIZARD process and directly set the coupling value that comes together with a particle set. <>= procedure :: set_alpha_qcd_forced => process_instance_set_alpha_qcd_forced <>= module subroutine process_instance_set_alpha_qcd_forced & (instance, i_term, alpha_qcd) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term real(default), intent(in) :: alpha_qcd end subroutine process_instance_set_alpha_qcd_forced <>= module subroutine process_instance_set_alpha_qcd_forced & (instance, i_term, alpha_qcd) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term real(default), intent(in) :: alpha_qcd call instance%term(i_term)%set_alpha_qcd_forced (alpha_qcd) end subroutine process_instance_set_alpha_qcd_forced @ %def process_instance_set_alpha_qcd_forced @ <>= procedure :: has_nlo_component => process_instance_has_nlo_component <>= module function process_instance_has_nlo_component (instance) result (nlo) class(process_instance_t), intent(in) :: instance logical :: nlo end function process_instance_has_nlo_component <>= module function process_instance_has_nlo_component (instance) result (nlo) class(process_instance_t), intent(in) :: instance logical :: nlo nlo = instance%process%is_nlo_calculation () end function process_instance_has_nlo_component @ %def process_instance_has_nlo_component @ <>= procedure :: keep_failed_events => process_instance_keep_failed_events <>= module function process_instance_keep_failed_events (instance) result (keep) logical :: keep class(process_instance_t), intent(in) :: instance end function process_instance_keep_failed_events <>= module function process_instance_keep_failed_events (instance) result (keep) logical :: keep class(process_instance_t), intent(in) :: instance keep = instance%mci_work(instance%i_mci)%keep_failed_events end function process_instance_keep_failed_events @ %def process_instance_keep_failed_events @ <>= procedure :: get_term_indices => process_instance_get_term_indices <>= module function process_instance_get_term_indices & (instance, nlo_type) result (i_term) integer, dimension(:), allocatable :: i_term class(process_instance_t), intent(in) :: instance integer :: nlo_type end function process_instance_get_term_indices <>= module function process_instance_get_term_indices & (instance, nlo_type) result (i_term) integer, dimension(:), allocatable :: i_term class(process_instance_t), intent(in) :: instance integer :: nlo_type allocate (i_term (count (instance%term%nlo_type == nlo_type))) i_term = pack (instance%term%get_i_term_global (), & instance%term%nlo_type == nlo_type) end function process_instance_get_term_indices @ %def process_instance_get_term_indices @ <>= procedure :: get_boost_to_lab => process_instance_get_boost_to_lab <>= module function process_instance_get_boost_to_lab & (instance, i_term) result (lt) type(lorentz_transformation_t) :: lt class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term end function process_instance_get_boost_to_lab <>= module function process_instance_get_boost_to_lab & (instance, i_term) result (lt) type(lorentz_transformation_t) :: lt class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term lt = instance%kin(i_term)%get_boost_to_lab () end function process_instance_get_boost_to_lab @ %def process_instance_get_boost_to_lab @ <>= procedure :: get_boost_to_cms => process_instance_get_boost_to_cms <>= module function process_instance_get_boost_to_cms & (instance, i_term) result (lt) type(lorentz_transformation_t) :: lt class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term end function process_instance_get_boost_to_cms <>= module function process_instance_get_boost_to_cms & (instance, i_term) result (lt) type(lorentz_transformation_t) :: lt class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term lt = instance%kin(i_term)%get_boost_to_cms () end function process_instance_get_boost_to_cms @ %def process_instance_get_boost_to_cms @ <>= procedure :: lab_is_cm => process_instance_lab_is_cm <>= module function process_instance_lab_is_cm & (instance, i_term) result (lab_is_cm) logical :: lab_is_cm class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term end function process_instance_lab_is_cm <>= module function process_instance_lab_is_cm & (instance, i_term) result (lab_is_cm) logical :: lab_is_cm class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term lab_is_cm = instance%kin(i_term)%phs%lab_is_cm () end function process_instance_lab_is_cm @ %def process_instance_lab_is_cm @ The [[pacify]] subroutine has the purpose of setting numbers to zero which are (by comparing with a [[tolerance]] parameter) considered equivalent with zero. We do this in some unit tests. Here, we a apply this to the phase space subobject of the process instance. <>= public :: pacify <>= interface pacify module procedure pacify_process_instance end interface pacify <>= module subroutine pacify_process_instance (instance) type(process_instance_t), intent(inout) :: instance end subroutine pacify_process_instance <>= module subroutine pacify_process_instance (instance) type(process_instance_t), intent(inout) :: instance integer :: i do i = 1, size (instance%kin) call pacify (instance%kin(i)%phs) end do end subroutine pacify_process_instance @ %def pacify @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Unit tests} Test module, followed by the corresponding implementation module. <<[[processes_ut.f90]]>>= <> module processes_ut use unit_tests use processes_uti <> <> <> contains <> end module processes_ut @ %def processes_ut @ <<[[processes_uti.f90]]>>= <> module processes_uti <> <> use format_utils, only: write_separator use constants, only: TWOPI4 use physics_defs, only: CONV use os_interface use sm_qcd use lorentz use pdg_arrays use model_data use models use var_base, only: vars_t use variables, only: var_list_t use model_testbed, only: prepare_model use particle_specifiers, only: new_prt_spec use flavors use interactions, only: reset_interaction_counter use particles use rng_base use mci_base use mci_none, only: mci_none_t use mci_midpoint use sf_mappings use sf_base use phs_base use phs_single use phs_forests, only: syntax_phs_forest_init, syntax_phs_forest_final use phs_wood, only: phs_wood_config_t use resonances, only: resonance_history_set_t use process_constants use prc_core_def, only: prc_core_def_t use prc_core use prc_test, only: prc_test_create_library use prc_template_me, only: template_me_def_t use process_libraries use prc_test_core use pdf, only: pdf_data_t use process_counter use process_config, only: process_term_t use process, only: process_t use instances, only: process_instance_t, process_instance_hook_t use rng_base_ut, only: rng_test_factory_t use sf_base_ut, only: sf_test_data_t use mci_base_ut, only: mci_test_t use phs_base_ut, only: phs_test_config_t <> <> <> <> contains <> <> end module processes_uti @ %def processes_uti @ API: driver for the unit tests below. <>= public :: processes_test <>= subroutine processes_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine processes_test @ %def processes_test \subsubsection{Write an empty process object} The most trivial test is to write an uninitialized process object. <>= call test (processes_1, "processes_1", & "write an empty process object", & u, results) <>= public :: processes_1 <>= subroutine processes_1 (u) integer, intent(in) :: u type(process_t) :: process write (u, "(A)") "* Test output: processes_1" write (u, "(A)") "* Purpose: display an empty process object" write (u, "(A)") call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Test output end: processes_1" end subroutine processes_1 @ %def processes_1 @ \subsubsection{Initialize a process object} Initialize a process and display it. <>= call test (processes_2, "processes_2", & "initialize a simple process object", & u, results) <>= public :: processes_2 <>= subroutine processes_2 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable :: process class(mci_t), allocatable :: mci_template class(phs_config_t), allocatable :: phs_config_template write (u, "(A)") "* Test output: processes_2" write (u, "(A)") "* Purpose: initialize a simple process object" write (u, "(A)") write (u, "(A)") "* Build and load a test library with one process" write (u, "(A)") libname = "processes2" procname = libname call os_data%init () call prc_test_create_library (libname, lib) write (u, "(A)") "* Initialize a process object" write (u, "(A)") call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%set_run_id (var_str ("run_2")) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) call process%setup_mci (dispatch_mci_empty) call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Cleanup" call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_2" end subroutine processes_2 @ %def processes_2 @ Trivial for testing: do not allocate the MCI record. <>= subroutine dispatch_mci_empty (mci, var_list, process_id, is_nlo) class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo end subroutine dispatch_mci_empty @ %def dispatch_mci_empty @ \subsubsection{Compute a trivial matrix element} Initialize a process, retrieve some information and compute a matrix element. We use the same trivial process as for the previous test. All momentum and state dependence is trivial, so we just test basic functionality. <>= call test (processes_3, "processes_3", & "retrieve a trivial matrix element", & u, results) <>= public :: processes_3 <>= subroutine processes_3 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable :: process class(phs_config_t), allocatable :: phs_config_template type(process_constants_t) :: data type(vector4_t), dimension(:), allocatable :: p write (u, "(A)") "* Test output: processes_3" write (u, "(A)") "* Purpose: create a process & &and compute a matrix element" write (u, "(A)") write (u, "(A)") "* Build and load a test library with one process" write (u, "(A)") libname = "processes3" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) call process%setup_mci (dispatch_mci_test3) write (u, "(A)") "* Return the number of process components" write (u, "(A)") write (u, "(A,I0)") "n_components = ", process%get_n_components () write (u, "(A)") write (u, "(A)") "* Return the number of flavor states" write (u, "(A)") data = process%get_constants (1) write (u, "(A,I0)") "n_flv(1) = ", data%n_flv write (u, "(A)") write (u, "(A)") "* Return the first flavor state" write (u, "(A)") write (u, "(A,4(1x,I0))") "flv_state(1) =", data%flv_state (:,1) write (u, "(A)") write (u, "(A)") "* Set up kinematics & &[arbitrary, the matrix element is constant]" allocate (p (4)) write (u, "(A)") write (u, "(A)") "* Retrieve the matrix element" write (u, "(A)") write (u, "(A,F5.3,' + ',F5.3,' I')") "me (1, p, 1, 1, 1) = ", & process%compute_amplitude (1, 1, 1, p, 1, 1, 1) write (u, "(A)") write (u, "(A)") "* Cleanup" call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_3" end subroutine processes_3 @ %def processes_3 @ MCI record with some contents. <>= subroutine dispatch_mci_test3 (mci, var_list, process_id, is_nlo) class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_test_t :: mci) select type (mci) type is (mci_test_t) call mci%set_dimensions (2, 2) call mci%set_divisions (100) end select end subroutine dispatch_mci_test3 @ %def dispatch_mci_test3 @ \subsubsection{Generate a process instance} Initialize a process and process instance, choose a sampling point and fill the process instance. We use the same trivial process as for the previous test. All momentum and state dependence is trivial, so we just test basic functionality. <>= call test (processes_4, "processes_4", & "create and fill a process instance (partonic event)", & u, results) <>= public :: processes_4 <>= subroutine processes_4 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t), allocatable, target :: process_instance type(particle_set_t) :: pset write (u, "(A)") "* Test output: processes_4" write (u, "(A)") "* Purpose: create a process & &and fill a process instance" write (u, "(A)") write (u, "(A)") "* Build and initialize a test process" write (u, "(A)") libname = "processes4" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call reset_interaction_counter () call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_empty) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Inject a set of random numbers" write (u, "(A)") call process_instance%choose_mci (1) call process_instance%set_mcpar ([0._default, 0._default]) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Set up hard kinematics" write (u, "(A)") call process_instance%select_channel (1) call process_instance%compute_seed_kinematics () call process_instance%compute_hard_kinematics () call process_instance%compute_eff_kinematics () call process_instance%evaluate_expressions () call process_instance%compute_other_channels () write (u, "(A)") "* Evaluate matrix element and square" write (u, "(A)") call process_instance%evaluate_trace () call process_instance%write (u) call process_instance%get_trace (pset, 1) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1, check_match = .false.) call process_instance%activate () process_instance%evaluation_status = STAT_EFF_KINEMATICS call process_instance%recover_hard_kinematics (i_term = 1) call process_instance%recover_seed_kinematics (i_term = 1) call process_instance%select_channel (1) call process_instance%recover_mcpar (i_term = 1) call process_instance%compute_seed_kinematics (skip_term = 1) call process_instance%compute_hard_kinematics (skip_term = 1) call process_instance%compute_eff_kinematics (skip_term = 1) call process_instance%evaluate_expressions () call process_instance%compute_other_channels (skip_term = 1) call process_instance%evaluate_trace () call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call pset%final () call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_4" end subroutine processes_4 @ %def processes_4 @ \subsubsection{Structure function configuration} Configure structure functions (multi-channel) in a process object. <>= call test (processes_7, "processes_7", & "process configuration with structure functions", & u, results) <>= public :: processes_7 <>= subroutine processes_7 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data type(sf_config_t), dimension(:), allocatable :: sf_config type(sf_channel_t), dimension(2) :: sf_channel write (u, "(A)") "* Test output: processes_7" write (u, "(A)") "* Purpose: initialize a process with & &structure functions" write (u, "(A)") write (u, "(A)") "* Build and initialize a process object" write (u, "(A)") libname = "processes7" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Set beam, structure functions, and mappings" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () pdg_in = 25 allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (process%get_model_ptr (), pdg_in) end select allocate (sf_config (2)) call sf_config(1)%init ([1], data) call sf_config(2)%init ([2], data) call process%init_sf_chain (sf_config) deallocate (sf_config) call process%test_allocate_sf_channels (3) call sf_channel(1)%init (2) call sf_channel(1)%activate_mapping ([1,2]) call process%set_sf_channel (2, sf_channel(1)) call sf_channel(2)%init (2) call sf_channel(2)%set_s_mapping ([1,2]) call process%set_sf_channel (3, sf_channel(2)) call process%setup_mci (dispatch_mci_empty) call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Cleanup" call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_7" end subroutine processes_7 @ %def processes_7 @ \subsubsection{Evaluating a process with structure function} Configure structure functions (single-channel) in a process object, create an instance, compute kinematics and evaluate. Note the order of operations when setting up structure functions and phase space. The beams are first, they determine the [[sqrts]] value. We can also set up the chain of structure functions. We then configure the phase space. From this, we can obtain information about special configurations (resonances, etc.), which we need for allocating the possible structure-function channels (parameterizations and mappings). Finally, we match phase-space channels onto structure-function channels. In the current example, this matching is trivial; we only have one structure-function channel. <>= call test (processes_8, "processes_8", & "process evaluation with structure functions", & u, results) <>= public :: processes_8 <>= subroutine processes_8 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t), allocatable, target :: process_instance type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data type(sf_config_t), dimension(:), allocatable :: sf_config type(sf_channel_t) :: sf_channel type(particle_set_t) :: pset write (u, "(A)") "* Test output: processes_8" write (u, "(A)") "* Purpose: evaluate a process with & &structure functions" write (u, "(A)") write (u, "(A)") "* Build and initialize a process object" write (u, "(A)") libname = "processes8" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call reset_interaction_counter () call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Set beam, structure functions, and mappings" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) pdg_in = 25 allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (process%get_model_ptr (), pdg_in) end select allocate (sf_config (2)) call sf_config(1)%init ([1], data) call sf_config(2)%init ([2], data) call process%init_sf_chain (sf_config) deallocate (sf_config) call process%configure_phs () call process%test_allocate_sf_channels (1) call sf_channel%init (2) call sf_channel%activate_mapping ([1,2]) call process%set_sf_channel (1, sf_channel) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_mci (dispatch_mci_empty) call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) write (u, "(A)") "* Set up kinematics and evaluate" write (u, "(A)") call process_instance%choose_mci (1) call process_instance%evaluate_sqme (1, & [0.8_default, 0.8_default, 0.1_default, 0.2_default]) call process_instance%write (u) call process_instance%get_trace (pset, 1) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover process instance" write (u, "(A)") call reset_interaction_counter (2) allocate (process_instance) call process_instance%init (process) call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1, check_match = .false.) call process_instance%recover & (channel = 1, i_term = 1, update_sqme = .true., recover_phs = .true.) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call pset%final () call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_8" end subroutine processes_8 @ %def processes_8 @ \subsubsection{Multi-channel phase space and structure function} This is an extension of the previous example. This time, we have two distinct structure-function channels which are matched to the two distinct phase-space channels. <>= call test (processes_9, "processes_9", & "multichannel kinematics and structure functions", & u, results) <>= public :: processes_9 <>= subroutine processes_9 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t), allocatable, target :: process_instance type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data type(sf_config_t), dimension(:), allocatable :: sf_config type(sf_channel_t) :: sf_channel real(default), dimension(4) :: x_saved type(particle_set_t) :: pset write (u, "(A)") "* Test output: processes_9" write (u, "(A)") "* Purpose: evaluate a process with & &structure functions" write (u, "(A)") "* in a multi-channel configuration" write (u, "(A)") write (u, "(A)") "* Build and initialize a process object" write (u, "(A)") libname = "processes9" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call reset_interaction_counter () call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Set beam, structure functions, and mappings" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) pdg_in = 25 allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (process%get_model_ptr (), pdg_in) end select allocate (sf_config (2)) call sf_config(1)%init ([1], data) call sf_config(2)%init ([2], data) call process%init_sf_chain (sf_config) deallocate (sf_config) call process%configure_phs () call process%test_allocate_sf_channels (2) call sf_channel%init (2) call process%set_sf_channel (1, sf_channel) call sf_channel%init (2) call sf_channel%activate_mapping ([1,2]) call process%set_sf_channel (2, sf_channel) call process%test_set_component_sf_channel ([1, 2]) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_mci (dispatch_mci_empty) call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) write (u, "(A)") "* Set up kinematics in channel 1 and evaluate" write (u, "(A)") call process_instance%choose_mci (1) call process_instance%evaluate_sqme (1, & [0.8_default, 0.8_default, 0.1_default, 0.2_default]) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Extract MC input parameters" write (u, "(A)") write (u, "(A)") "Channel 1:" call process_instance%get_mcpar (1, x_saved) write (u, "(2x,9(1x,F7.5))") x_saved write (u, "(A)") "Channel 2:" call process_instance%get_mcpar (2, x_saved) write (u, "(2x,9(1x,F7.5))") x_saved write (u, "(A)") write (u, "(A)") "* Set up kinematics in channel 2 and evaluate" write (u, "(A)") call process_instance%evaluate_sqme (2, x_saved) call process_instance%write (u) call process_instance%get_trace (pset, 1) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Recover process instance for channel 2" write (u, "(A)") call reset_interaction_counter (2) allocate (process_instance) call process_instance%init (process) call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1, check_match = .false.) call process_instance%recover & (channel = 2, i_term = 1, update_sqme = .true., recover_phs = .true.) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call pset%final () call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_9" end subroutine processes_9 @ %def processes_9 @ \subsubsection{Event generation} Activate the MC integrator for the process object and use it to generate a single event. Note that the test integrator does not require integration in preparation for generating events. <>= call test (processes_10, "processes_10", & "event generation", & u, results) <>= public :: processes_10 <>= subroutine processes_10 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(mci_t), pointer :: mci class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t), allocatable, target :: process_instance write (u, "(A)") "* Test output: processes_10" write (u, "(A)") "* Purpose: generate events for a process without & &structure functions" write (u, "(A)") "* in a multi-channel configuration" write (u, "(A)") write (u, "(A)") "* Build and initialize a process object" write (u, "(A)") libname = "processes10" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call reset_interaction_counter () call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_test10) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) write (u, "(A)") "* Generate weighted event" write (u, "(A)") call process%test_get_mci_ptr (mci) select type (mci) type is (mci_test_t) ! This ensures that the next 'random' numbers are 0.3, 0.5, 0.7 call mci%rng%init (3) ! Include the constant PHS factor in the stored maximum of the integrand call mci%set_max_factor (conv * twopi4 & / (2 * sqrt (lambda (sqrts **2, 125._default**2, 125._default**2)))) end select call process_instance%generate_weighted_event (1) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Generate unweighted event" write (u, "(A)") call process_instance%generate_unweighted_event (1) call process%test_get_mci_ptr (mci) select type (mci) type is (mci_test_t) write (u, "(A,I0)") " Success in try ", mci%tries write (u, "(A)") end select call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_10" end subroutine processes_10 @ %def processes_10 @ MCI record with some contents. <>= subroutine dispatch_mci_test10 (mci, var_list, process_id, is_nlo) class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_test_t :: mci) select type (mci) type is (mci_test_t); call mci%set_divisions (100) end select end subroutine dispatch_mci_test10 @ %def dispatch_mci_test10 @ \subsubsection{Integration} Activate the MC integrator for the process object and use it to integrate over phase space. <>= call test (processes_11, "processes_11", & "integration", & u, results) <>= public :: processes_11 <>= subroutine processes_11 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(mci_t), allocatable :: mci_template class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t), allocatable, target :: process_instance write (u, "(A)") "* Test output: processes_11" write (u, "(A)") "* Purpose: integrate a process without & &structure functions" write (u, "(A)") "* in a multi-channel configuration" write (u, "(A)") write (u, "(A)") "* Build and initialize a process object" write (u, "(A)") libname = "processes11" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call reset_interaction_counter () call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_test10) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) write (u, "(A)") "* Integrate with default test parameters" write (u, "(A)") call process_instance%integrate (1, n_it=1, n_calls=10000) call process%final_integration (1) call process%write (.false., u) write (u, "(A)") write (u, "(A,ES13.7)") " Integral divided by phs factor = ", & process%get_integral (1) & / process_instance%kin(1)%phs_factor write (u, "(A)") write (u, "(A)") "* Cleanup" call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_11" end subroutine processes_11 @ %def processes_11 @ \subsubsection{Complete events} For the purpose of simplifying further tests, we implement a convenience routine that initializes a process and prepares a single event. This is a wrapup of the test [[processes_10]]. The procedure is re-exported by the [[processes_ut]] module. <>= public :: prepare_test_process <>= subroutine prepare_test_process & (process, process_instance, model, var_list, run_id) type(process_t), intent(out), target :: process type(process_instance_t), intent(out), target :: process_instance class(model_data_t), intent(in), target :: model type(var_list_t), intent(inout), optional :: var_list type(string_t), intent(in), optional :: run_id type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), allocatable, target :: process_model class(mci_t), pointer :: mci class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts libname = "processes_test" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call reset_interaction_counter () allocate (process_model) call process_model%init (model%get_name (), & model%get_n_real (), & model%get_n_complex (), & model%get_n_field (), & model%get_n_vtx ()) call process_model%copy_from (model) call process%init (procname, lib, os_data, process_model, var_list) if (present (run_id)) call process%set_run_id (run_id) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_test10) call process%setup_terms () call process_instance%init (process) call process%test_get_mci_ptr (mci) select type (mci) type is (mci_test_t) ! This ensures that the next 'random' numbers are 0.3, 0.5, 0.7 call mci%rng%init (3) ! Include the constant PHS factor in the stored maximum of the integrand call mci%set_max_factor (conv * twopi4 & / (2 * sqrt (lambda (sqrts **2, 125._default**2, 125._default**2)))) end select call process%reset_library_ptr () ! avoid dangling pointer call process_model%final () end subroutine prepare_test_process @ %def prepare_test_process @ Here we do the cleanup of the process and process instance emitted by the previous routine. <>= public :: cleanup_test_process <>= subroutine cleanup_test_process (process, process_instance) type(process_t), intent(inout) :: process type(process_instance_t), intent(inout) :: process_instance call process_instance%final () call process%final () end subroutine cleanup_test_process @ %def cleanup_test_process @ This is the actual test. Prepare the test process and event, fill all evaluators, and display the results. Use a particle set as temporary storage, read kinematics and recalculate the event. <>= call test (processes_12, "processes_12", & "event post-processing", & u, results) <>= public :: processes_12 <>= subroutine processes_12 (u) integer, intent(in) :: u type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance type(particle_set_t) :: pset type(model_data_t), target :: model write (u, "(A)") "* Test output: processes_12" write (u, "(A)") "* Purpose: generate a complete partonic event" write (u, "(A)") call model%init_test () write (u, "(A)") "* Build and initialize process and process instance & &and generate event" write (u, "(A)") allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model, & run_id = var_str ("run_12")) call process_instance%setup_event_data (i_core = 1) call process%prepare_simulation (1) call process_instance%init_simulation (1) call process_instance%generate_weighted_event (1) call process_instance%evaluate_event_data () call process_instance%write (u) call process_instance%get_trace (pset, 1) call process_instance%final_simulation (1) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Recover kinematics and recalculate" write (u, "(A)") call reset_interaction_counter (2) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1, check_match = .false.) call process_instance%recover & (channel = 1, i_term = 1, update_sqme = .true., recover_phs = .true.) call process_instance%recover_event () call process_instance%evaluate_event_data () call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call cleanup_test_process (process, process_instance) deallocate (process_instance) deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_12" end subroutine processes_12 @ %def processes_12 @ \subsubsection{Colored interaction} This test specifically checks the transformation of process data (flavor, helicity, and color) into an interaction in a process term. We use the [[test_t]] process core (which has no nontrivial particles), but call only the [[is_allowed]] method, which always returns true. <>= call test (processes_13, "processes_13", & "colored interaction", & u, results) <>= public :: processes_13 <>= subroutine processes_13 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(process_term_t) :: term class(prc_core_t), allocatable :: core write (u, "(A)") "* Test output: processes_13" write (u, "(A)") "* Purpose: initialized a colored interaction" write (u, "(A)") write (u, "(A)") "* Set up a process constants block" write (u, "(A)") call os_data%init () call model%init_sm_test () allocate (test_t :: core) associate (data => term%data) data%n_in = 2 data%n_out = 3 data%n_flv = 2 data%n_hel = 2 data%n_col = 2 data%n_cin = 2 allocate (data%flv_state (5, 2)) data%flv_state (:,1) = [ 1, 21, 1, 21, 21] data%flv_state (:,2) = [ 2, 21, 2, 21, 21] allocate (data%hel_state (5, 2)) data%hel_state (:,1) = [1, 1, 1, 1, 0] data%hel_state (:,2) = [1,-1, 1,-1, 0] allocate (data%col_state (2, 5, 2)) data%col_state (:,:,1) = & reshape ([[1, 0], [2,-1], [3, 0], [2,-3], [0,0]], [2,5]) data%col_state (:,:,2) = & reshape ([[1, 0], [2,-3], [3, 0], [2,-1], [0,0]], [2,5]) allocate (data%ghost_flag (5, 2)) data%ghost_flag(1:4,:) = .false. data%ghost_flag(5,:) = .true. end associate write (u, "(A)") "* Set up the interaction" write (u, "(A)") call reset_interaction_counter () call term%setup_interaction (core, model) call term%int%basic_write (u) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_13" end subroutine processes_13 @ %def processes_13 @ \subsubsection{MD5 sums} Configure a process with structure functions (multi-channel) and compute MD5 sums <>= call test (processes_14, "processes_14", & "process configuration and MD5 sum", & u, results) <>= public :: processes_14 <>= subroutine processes_14 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data type(sf_config_t), dimension(:), allocatable :: sf_config type(sf_channel_t), dimension(3) :: sf_channel write (u, "(A)") "* Test output: processes_14" write (u, "(A)") "* Purpose: initialize a process with & &structure functions" write (u, "(A)") "* and compute MD5 sum" write (u, "(A)") write (u, "(A)") "* Build and initialize a process object" write (u, "(A)") libname = "processes7" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call lib%compute_md5sum () call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Set beam, structure functions, and mappings" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () pdg_in = 25 allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (process%get_model_ptr (), pdg_in) end select call process%test_allocate_sf_channels (3) allocate (sf_config (2)) call sf_config(1)%init ([1], data) call sf_config(2)%init ([2], data) call process%init_sf_chain (sf_config) deallocate (sf_config) call sf_channel(1)%init (2) call process%set_sf_channel (1, sf_channel(1)) call sf_channel(2)%init (2) call sf_channel(2)%activate_mapping ([1,2]) call process%set_sf_channel (2, sf_channel(2)) call sf_channel(3)%init (2) call sf_channel(3)%set_s_mapping ([1,2]) call process%set_sf_channel (3, sf_channel(3)) call process%setup_mci (dispatch_mci_empty) call process%compute_md5sum () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Cleanup" call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_14" end subroutine processes_14 @ %def processes_14 @ \subsubsection{Decay Process Evaluation} Initialize an evaluate a decay process. <>= call test (processes_15, "processes_15", & "decay process", & u, results) <>= public :: processes_15 <>= subroutine processes_15 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template type(process_instance_t), allocatable, target :: process_instance type(particle_set_t) :: pset write (u, "(A)") "* Test output: processes_15" write (u, "(A)") "* Purpose: initialize a decay process object" write (u, "(A)") write (u, "(A)") "* Build and load a test library with one process" write (u, "(A)") libname = "processes15" procname = libname call os_data%init () call prc_test_create_library (libname, lib, scattering = .false., & decay = .true.) call model%init_test () call model%set_par (var_str ("ff"), 0.4_default) call model%set_par (var_str ("mf"), & model%get_real (var_str ("ff")) * model%get_real (var_str ("ms"))) write (u, "(A)") "* Initialize a process object" write (u, "(A)") allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_single_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") call process%setup_beams_decay (i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_empty) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") call reset_interaction_counter (3) allocate (process_instance) call process_instance%init (process) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Inject a set of random numbers" write (u, "(A)") call process_instance%choose_mci (1) call process_instance%set_mcpar ([0._default, 0._default]) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Set up hard kinematics" write (u, "(A)") call process_instance%select_channel (1) call process_instance%compute_seed_kinematics () call process_instance%compute_hard_kinematics () write (u, "(A)") "* Evaluate matrix element and square" write (u, "(A)") call process_instance%compute_eff_kinematics () call process_instance%evaluate_expressions () call process_instance%compute_other_channels () call process_instance%evaluate_trace () call process_instance%write (u) call process_instance%get_trace (pset, 1) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover process instance" write (u, "(A)") call reset_interaction_counter (3) allocate (process_instance) call process_instance%init (process) call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1, check_match = .false.) call process_instance%recover (1, 1, .true., .true.) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call pset%final () call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_15" end subroutine processes_15 @ %def processes_15 @ \subsubsection{Integration: decay} Activate the MC integrator for the decay object and use it to integrate over phase space. <>= call test (processes_16, "processes_16", & "decay integration", & u, results) <>= public :: processes_16 <>= subroutine processes_16 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template type(process_instance_t), allocatable, target :: process_instance write (u, "(A)") "* Test output: processes_16" write (u, "(A)") "* Purpose: integrate a process without & &structure functions" write (u, "(A)") "* in a multi-channel configuration" write (u, "(A)") write (u, "(A)") "* Build and initialize a process object" write (u, "(A)") libname = "processes16" procname = libname call os_data%init () call prc_test_create_library (libname, lib, scattering = .false., & decay = .true.) call reset_interaction_counter () call model%init_test () call model%set_par (var_str ("ff"), 0.4_default) call model%set_par (var_str ("mf"), & model%get_real (var_str ("ff")) * model%get_real (var_str ("ms"))) allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_single_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") call process%setup_beams_decay (i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_test_midpoint) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) write (u, "(A)") "* Integrate with default test parameters" write (u, "(A)") call process_instance%integrate (1, n_it=1, n_calls=10000) call process%final_integration (1) call process%write (.false., u) write (u, "(A)") write (u, "(A,ES13.7)") " Integral divided by phs factor = ", & process%get_integral (1) & / process_instance%kin(1)%phs_factor write (u, "(A)") write (u, "(A)") "* Cleanup" call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_16" end subroutine processes_16 @ %def processes_16 @ MCI record prepared for midpoint integrator. <>= subroutine dispatch_mci_test_midpoint (mci, var_list, process_id, is_nlo) class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_midpoint_t :: mci) end subroutine dispatch_mci_test_midpoint @ %def dispatch_mci_test_midpoint @ \subsubsection{Decay Process Evaluation} Initialize an evaluate a decay process for a moving particle. <>= call test (processes_17, "processes_17", & "decay of moving particle", & u, results) <>= public :: processes_17 <>= subroutine processes_17 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template type(process_instance_t), allocatable, target :: process_instance type(particle_set_t) :: pset type(flavor_t) :: flv_beam real(default) :: m, p, E write (u, "(A)") "* Test output: processes_17" write (u, "(A)") "* Purpose: initialize a decay process object" write (u, "(A)") write (u, "(A)") "* Build and load a test library with one process" write (u, "(A)") libname = "processes17" procname = libname call os_data%init () call prc_test_create_library (libname, lib, scattering = .false., & decay = .true.) write (u, "(A)") "* Initialize a process object" write (u, "(A)") call model%init_test () call model%set_par (var_str ("ff"), 0.4_default) call model%set_par (var_str ("mf"), & model%get_real (var_str ("ff")) * model%get_real (var_str ("ms"))) allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_single_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") call process%setup_beams_decay (rest_frame = .false., i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_empty) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") call reset_interaction_counter (3) allocate (process_instance) call process_instance%init (process) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Set parent momentum and random numbers" write (u, "(A)") call process_instance%choose_mci (1) call process_instance%set_mcpar ([0._default, 0._default]) call flv_beam%init (25, process%get_model_ptr ()) m = flv_beam%get_mass () p = 3 * m / 4 E = sqrt (m**2 + p**2) call process_instance%set_beam_momenta ([vector4_moving (E, p, 3)]) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Set up hard kinematics" write (u, "(A)") call process_instance%select_channel (1) call process_instance%compute_seed_kinematics () call process_instance%compute_hard_kinematics () write (u, "(A)") "* Evaluate matrix element and square" write (u, "(A)") call process_instance%compute_eff_kinematics () call process_instance%evaluate_expressions () call process_instance%compute_other_channels () call process_instance%evaluate_trace () call process_instance%write (u) call process_instance%get_trace (pset, 1) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover process instance" write (u, "(A)") call reset_interaction_counter (3) allocate (process_instance) call process_instance%init (process) call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1, check_match = .false.) call process_instance%recover (1, 1, .true., .true.) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call pset%final () call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_17" end subroutine processes_17 @ %def processes_17 @ \subsubsection{Resonances in Phase Space} This test demonstrates the extraction of the resonance-history set from the generated phase space. We need a nontrivial process, but no matrix element. This is provided by the [[prc_template]] method, using the [[SM]] model. We also need the [[phs_wood]] method, otherwise we would not have resonances in the phase space configuration. <>= call test (processes_18, "processes_18", & "extract resonance history set", & u, results) <>= public :: processes_18 <>= subroutine processes_18 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(string_t) :: model_name type(os_data_t) :: os_data class(model_data_t), pointer :: model class(vars_t), pointer :: vars type(process_t), pointer :: process type(resonance_history_set_t) :: res_set integer :: i write (u, "(A)") "* Test output: processes_18" write (u, "(A)") "* Purpose: extra resonance histories" write (u, "(A)") write (u, "(A)") "* Build and load a test library with one process" write (u, "(A)") libname = "processes_18_lib" procname = "processes_18_p" call os_data%init () call syntax_phs_forest_init () model_name = "SM" model => null () call prepare_model (model, model_name, vars) write (u, "(A)") "* Initialize a process library with one process" write (u, "(A)") select type (model) class is (model_t) call prepare_resonance_test_library (lib, libname, procname, model, os_data, u) end select write (u, "(A)") write (u, "(A)") "* Initialize a process object with phase space" allocate (process) select type (model) class is (model_t) call prepare_resonance_test_process (process, lib, procname, model, os_data) end select write (u, "(A)") write (u, "(A)") "* Extract resonance history set" write (u, "(A)") call process%extract_resonance_history_set (res_set) call res_set%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call process%final () deallocate (process) call model%final () deallocate (model) call syntax_phs_forest_final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_18" end subroutine processes_18 @ %def processes_18 @ Auxiliary subroutine that constructs the process library for the above test. <>= subroutine prepare_resonance_test_library & (lib, libname, procname, model, os_data, u) type(process_library_t), target, intent(out) :: lib type(string_t), intent(in) :: libname type(string_t), intent(in) :: procname type(model_t), intent(in), target :: model type(os_data_t), intent(in) :: os_data integer, intent(in) :: u type(string_t), dimension(:), allocatable :: prt_in, prt_out class(prc_core_def_t), allocatable :: def type(process_def_entry_t), pointer :: entry call lib%init (libname) allocate (prt_in (2), prt_out (3)) prt_in = [var_str ("e+"), var_str ("e-")] prt_out = [var_str ("d"), var_str ("ubar"), var_str ("W+")] allocate (template_me_def_t :: def) select type (def) type is (template_me_def_t) call def%init (model, prt_in, prt_out, unity = .false.) end select allocate (entry) call entry%init (procname, & model_name = model%get_name (), & n_in = 2, n_components = 1) call entry%import_component (1, n_out = size (prt_out), & prt_in = new_prt_spec (prt_in), & prt_out = new_prt_spec (prt_out), & method = var_str ("template"), & variant = def) call entry%write (u) call lib%append (entry) call lib%configure (os_data) call lib%write_makefile (os_data, force = .true., verbose = .false.) call lib%clean (os_data, distclean = .false.) call lib%write_driver (force = .true.) call lib%load (os_data) end subroutine prepare_resonance_test_library @ %def prepare_resonance_test_library @ We want a test process which has been initialized up to the point where we can evaluate the matrix element. This is in fact rather complicated. We copy the steps from [[integration_setup_process]] in the [[integrate]] module, which is not available at this point. <>= subroutine prepare_resonance_test_process & (process, lib, procname, model, os_data) class(process_t), intent(out), target :: process type(process_library_t), intent(in), target :: lib type(string_t), intent(in) :: procname type(model_t), intent(in), target :: model type(os_data_t), intent(in) :: os_data class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts call process%init (procname, lib, os_data, model) allocate (phs_wood_config_t :: phs_config_template) call process%init_components (phs_config_template) call process%setup_test_cores (type_string = var_str ("template")) sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_none) call process%setup_terms () end subroutine prepare_resonance_test_process @ %def prepare_resonance_test_process @ MCI record prepared for the none (dummy) integrator. <>= subroutine dispatch_mci_none (mci, var_list, process_id, is_nlo) class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_none_t :: mci) end subroutine dispatch_mci_none @ %def dispatch_mci_none @ \subsubsection{Add after evaluate hook(s)} Initialize a process and process instance, add a trivial process hook, choose a sampling point and fill the process instance. We use the same trivial process as for the previous test. All momentum and state dependence is trivial, so we just test basic functionality. <>= type, extends(process_instance_hook_t) :: process_instance_hook_test_t integer :: unit character(len=15) :: name contains procedure :: init => process_instance_hook_test_init procedure :: final => process_instance_hook_test_final procedure :: evaluate => process_instance_hook_test_evaluate end type process_instance_hook_test_t @ <>= subroutine process_instance_hook_test_init (hook, var_list, instance, pdf_data) class(process_instance_hook_test_t), intent(inout), target :: hook type(var_list_t), intent(in) :: var_list class(process_instance_t), intent(in), target :: instance type(pdf_data_t), intent(in), optional :: pdf_data end subroutine process_instance_hook_test_init subroutine process_instance_hook_test_final (hook) class(process_instance_hook_test_t), intent(inout) :: hook end subroutine process_instance_hook_test_final subroutine process_instance_hook_test_evaluate (hook, instance) class(process_instance_hook_test_t), intent(inout) :: hook class(process_instance_t), intent(in), target :: instance write (hook%unit, "(A)") "Execute hook:" write (hook%unit, "(2X,A,1X,A,I0,A)") hook%name, "(", len (trim (hook%name)), ")" end subroutine process_instance_hook_test_evaluate @ <>= call test (processes_19, "processes_19", & "add trivial hooks to a process instance ", & u, results) <>= public :: processes_19 <>= subroutine processes_19 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data class(model_data_t), pointer :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t) :: process_instance class(process_instance_hook_t), allocatable, target :: process_instance_hook, process_instance_hook2 type(particle_set_t) :: pset write (u, "(A)") "* Test output: processes_19" write (u, "(A)") "* Purpose: allocate process instance & &and add an after evaluate hook" write (u, "(A)") write (u, "(A)") write (u, "(A)") "* Allocate a process instance" write (u, "(A)") call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Allocate hook and add to process instance" write (u, "(A)") allocate (process_instance_hook_test_t :: process_instance_hook) call process_instance%append_after_hook (process_instance_hook) allocate (process_instance_hook_test_t :: process_instance_hook2) call process_instance%append_after_hook (process_instance_hook2) select type (process_instance_hook) type is (process_instance_hook_test_t) process_instance_hook%unit = u process_instance_hook%name = "Hook 1" end select select type (process_instance_hook2) type is (process_instance_hook_test_t) process_instance_hook2%unit = u process_instance_hook2%name = "Hook 2" end select write (u, "(A)") "* Evaluate matrix element and square" write (u, "(A)") call process_instance%evaluate_after_hook () write (u, "(A)") write (u, "(A)") "* Cleanup" call process_instance_hook%final () deallocate (process_instance_hook) write (u, "(A)") write (u, "(A)") "* Test output end: processes_19" end subroutine processes_19 @ %def processes_19 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process Stacks} For storing and handling multiple processes, we define process stacks. These are ordinary stacks where new process entries are pushed onto the top. We allow for multiple entries with identical process ID, but distinct run ID. The implementation is essentially identical to the [[prclib_stacks]] module above. Unfortunately, Fortran supports no generic programming, so we do not make use of this fact. When searching for a specific process ID, we will get (a pointer to) the topmost process entry with that ID on the stack, which was entered last. Usually, this is the best version of the process (in terms of integral, etc.) Thus the stack terminology makes sense. <<[[process_stacks.f90]]>>= <> module process_stacks <> <> use variables use process <> <> <> interface <> end interface end module process_stacks @ %def process_stacks @ <<[[process_stacks_sub.f90]]>>= <> submodule (process_stacks) process_stacks_s use io_units use format_utils, only: write_separator use diagnostics use observables implicit none contains <> end submodule process_stacks_s @ %def process_stacks_s @ \subsection{The process entry type} A process entry is a process object, augmented by a pointer to the next entry. We do not need specific methods, all relevant methods are inherited. On higher level, processes should be prepared as process entry objects. <>= public :: process_entry_t <>= type, extends (process_t) :: process_entry_t type(process_entry_t), pointer :: next => null () end type process_entry_t @ %def process_entry_t @ \subsection{The process stack type} For easy conversion and lookup it is useful to store the filling number in the object. The content is stored as a linked list. The [[var_list]] component stores process-specific results, so they can be retrieved as (pseudo) variables. The process stack can be linked to another one. This allows us to work with stacks of local scope. <>= public :: process_stack_t <>= type :: process_stack_t integer :: n = 0 type(process_entry_t), pointer :: first => null () type(var_list_t), pointer :: var_list => null () type(process_stack_t), pointer :: next => null () contains <> end type process_stack_t @ %def process_stack_t @ Finalize partly: deallocate the process stack and variable list entries, but keep the variable list as an empty object. This way, the variable list links are kept. <>= procedure :: clear => process_stack_clear <>= module subroutine process_stack_clear (stack) class(process_stack_t), intent(inout) :: stack end subroutine process_stack_clear <>= module subroutine process_stack_clear (stack) class(process_stack_t), intent(inout) :: stack type(process_entry_t), pointer :: process if (associated (stack%var_list)) then call stack%var_list%final () end if do while (associated (stack%first)) process => stack%first stack%first => process%next call process%final () deallocate (process) end do stack%n = 0 end subroutine process_stack_clear @ %def process_stack_clear @ Finalizer. Clear and deallocate the variable list. <>= procedure :: final => process_stack_final <>= module subroutine process_stack_final (object) class(process_stack_t), intent(inout) :: object end subroutine process_stack_final <>= module subroutine process_stack_final (object) class(process_stack_t), intent(inout) :: object call object%clear () if (associated (object%var_list)) then deallocate (object%var_list) end if end subroutine process_stack_final @ %def process_stack_final @ Output. The processes on the stack will be ordered LIFO, i.e., backwards. <>= procedure :: write => process_stack_write <>= recursive module subroutine process_stack_write (object, unit, pacify) class(process_stack_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify end subroutine process_stack_write <>= recursive module subroutine process_stack_write (object, unit, pacify) class(process_stack_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify type(process_entry_t), pointer :: process integer :: u u = given_output_unit (unit) call write_separator (u, 2) select case (object%n) case (0) write (u, "(1x,A)") "Process stack: [empty]" call write_separator (u, 2) case default write (u, "(1x,A)") "Process stack:" process => object%first do while (associated (process)) call process%write (.false., u, pacify = pacify) process => process%next end do end select if (associated (object%next)) then write (u, "(1x,A)") "[Processes from context environment:]" call object%next%write (u, pacify) end if end subroutine process_stack_write @ %def process_stack_write @ The variable list is printed by a separate routine, since it should be linked to the global variable list, anyway. <>= procedure :: write_var_list => process_stack_write_var_list <>= module subroutine process_stack_write_var_list (object, unit) class(process_stack_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine process_stack_write_var_list <>= module subroutine process_stack_write_var_list (object, unit) class(process_stack_t), intent(in) :: object integer, intent(in), optional :: unit if (associated (object%var_list)) then call object%var_list%write (unit) end if end subroutine process_stack_write_var_list @ %def process_stack_write_var_list @ Short output. Since this is a stack, the default output ordering for each stack will be last-in, first-out. To enable first-in, first-out, which is more likely to be requested, there is an optional [[fifo]] argument. <>= procedure :: show => process_stack_show <>= recursive module subroutine process_stack_show (object, unit, fifo) class(process_stack_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: fifo end subroutine process_stack_show <>= recursive module subroutine process_stack_show (object, unit, fifo) class(process_stack_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: fifo type(process_entry_t), pointer :: process logical :: reverse integer :: u, i, j u = given_output_unit (unit) reverse = .false.; if (present (fifo)) reverse = fifo select case (object%n) case (0) case default if (.not. reverse) then process => object%first do while (associated (process)) call process%show (u, verbose=.false.) process => process%next end do else do i = 1, object%n process => object%first do j = 1, object%n - i process => process%next end do call process%show (u, verbose=.false.) end do end if end select if (associated (object%next)) call object%next%show () end subroutine process_stack_show @ %def process_stack_show @ \subsection{Link} Link the current process stack to a global one. <>= procedure :: link => process_stack_link <>= module subroutine process_stack_link (local_stack, global_stack) class(process_stack_t), intent(inout) :: local_stack type(process_stack_t), intent(in), target :: global_stack end subroutine process_stack_link <>= module subroutine process_stack_link (local_stack, global_stack) class(process_stack_t), intent(inout) :: local_stack type(process_stack_t), intent(in), target :: global_stack local_stack%next => global_stack end subroutine process_stack_link @ %def process_stack_link @ Initialize the process variable list and link the main variable list to it. <>= procedure :: init_var_list => process_stack_init_var_list <>= module subroutine process_stack_init_var_list (stack, var_list) class(process_stack_t), intent(inout) :: stack type(var_list_t), intent(inout), optional :: var_list end subroutine process_stack_init_var_list <>= module subroutine process_stack_init_var_list (stack, var_list) class(process_stack_t), intent(inout) :: stack type(var_list_t), intent(inout), optional :: var_list allocate (stack%var_list) if (present (var_list)) call var_list%link (stack%var_list) end subroutine process_stack_init_var_list @ %def process_stack_init_var_list @ Link the process variable list to a global variable list. <>= procedure :: link_var_list => process_stack_link_var_list <>= module subroutine process_stack_link_var_list (stack, var_list) class(process_stack_t), intent(inout) :: stack type(var_list_t), intent(in), target :: var_list end subroutine process_stack_link_var_list <>= module subroutine process_stack_link_var_list (stack, var_list) class(process_stack_t), intent(inout) :: stack type(var_list_t), intent(in), target :: var_list call stack%var_list%link (var_list) end subroutine process_stack_link_var_list @ %def process_stack_link_var_list @ \subsection{Push} We take a process pointer and push it onto the stack. The previous pointer is nullified. Subsequently, the process is `owned' by the stack and will be finalized when the stack is deleted. <>= procedure :: push => process_stack_push <>= module subroutine process_stack_push (stack, process) class(process_stack_t), intent(inout) :: stack type(process_entry_t), intent(inout), pointer :: process end subroutine process_stack_push <>= module subroutine process_stack_push (stack, process) class(process_stack_t), intent(inout) :: stack type(process_entry_t), intent(inout), pointer :: process process%next => stack%first stack%first => process process => null () stack%n = stack%n + 1 end subroutine process_stack_push @ %def process_stack_push @ Inverse: Remove the last process pointer in the list and return it. <>= procedure :: pop_last => process_stack_pop_last <>= module subroutine process_stack_pop_last (stack, process) class(process_stack_t), intent(inout) :: stack type(process_entry_t), intent(inout), pointer :: process end subroutine process_stack_pop_last <>= module subroutine process_stack_pop_last (stack, process) class(process_stack_t), intent(inout) :: stack type(process_entry_t), intent(inout), pointer :: process type(process_entry_t), pointer :: previous integer :: i select case (stack%n) case (:0) process => null () case (1) process => stack%first stack%first => null () stack%n = 0 case (2:) process => stack%first do i = 2, stack%n previous => process process => process%next end do previous%next => null () stack%n = stack%n - 1 end select end subroutine process_stack_pop_last @ %def process_stack_pop_last @ Initialize process variables for a given process ID, without setting values. <>= procedure :: init_result_vars => process_stack_init_result_vars <>= module subroutine process_stack_init_result_vars (stack, id) class(process_stack_t), intent(inout) :: stack type(string_t), intent(in) :: id end subroutine process_stack_init_result_vars <>= module subroutine process_stack_init_result_vars (stack, id) class(process_stack_t), intent(inout) :: stack type(string_t), intent(in) :: id call var_list_init_num_id (stack%var_list, id) call var_list_init_process_results (stack%var_list, id) end subroutine process_stack_init_result_vars @ %def process_stack_init_result_vars @ Fill process variables with values. This is executed after the integration pass. Note: We set only integral and error. With multiple MCI records possible, the results for [[n_calls]], [[chi2]] etc. are not necessarily unique. (We might set the efficiency, though.) <>= procedure :: fill_result_vars => process_stack_fill_result_vars <>= module subroutine process_stack_fill_result_vars (stack, id) class(process_stack_t), intent(inout) :: stack type(string_t), intent(in) :: id end subroutine process_stack_fill_result_vars <>= module subroutine process_stack_fill_result_vars (stack, id) class(process_stack_t), intent(inout) :: stack type(string_t), intent(in) :: id type(process_t), pointer :: process process => stack%get_process_ptr (id) if (associated (process)) then call var_list_init_num_id (stack%var_list, id, process%get_num_id ()) if (process%has_integral ()) then call var_list_init_process_results (stack%var_list, id, & integral = process%get_integral (), & error = process%get_error ()) end if else call msg_bug ("process_stack_fill_result_vars: unknown process ID") end if end subroutine process_stack_fill_result_vars @ %def process_stack_fill_result_vars @ If one of the result variables has a local image in [[var_list_local]], update the value there as well. <>= procedure :: update_result_vars => process_stack_update_result_vars <>= module subroutine process_stack_update_result_vars & (stack, id, var_list_local) class(process_stack_t), intent(inout) :: stack type(string_t), intent(in) :: id type(var_list_t), intent(inout) :: var_list_local end subroutine process_stack_update_result_vars <>= module subroutine process_stack_update_result_vars (stack, id, var_list_local) class(process_stack_t), intent(inout) :: stack type(string_t), intent(in) :: id type(var_list_t), intent(inout) :: var_list_local call update ("integral(" // id // ")") call update ("error(" // id // ")") contains subroutine update (var_name) type(string_t), intent(in) :: var_name real(default) :: value if (var_list_local%contains (var_name, follow_link = .false.)) then value = stack%var_list%get_rval (var_name) call var_list_local%set_real (var_name, value, is_known = .true.) end if end subroutine update end subroutine process_stack_update_result_vars @ %def process_stack_update_result_vars @ \subsection{Data Access} Tell if a process exists. <>= procedure :: exists => process_stack_exists <>= module function process_stack_exists (stack, id) result (flag) class(process_stack_t), intent(in) :: stack type(string_t), intent(in) :: id logical :: flag end function process_stack_exists <>= module function process_stack_exists (stack, id) result (flag) class(process_stack_t), intent(in) :: stack type(string_t), intent(in) :: id logical :: flag type(process_t), pointer :: process process => stack%get_process_ptr (id) flag = associated (process) end function process_stack_exists @ %def process_stack_exists @ Return a pointer to a process with specific ID. Look also at a linked stack, if necessary. <>= procedure :: get_process_ptr => process_stack_get_process_ptr <>= recursive module function process_stack_get_process_ptr & (stack, id) result (ptr) class(process_stack_t), intent(in) :: stack type(string_t), intent(in) :: id type(process_t), pointer :: ptr end function process_stack_get_process_ptr <>= recursive module function process_stack_get_process_ptr & (stack, id) result (ptr) class(process_stack_t), intent(in) :: stack type(string_t), intent(in) :: id type(process_t), pointer :: ptr type(process_entry_t), pointer :: entry ptr => null () entry => stack%first do while (associated (entry)) if (entry%get_id () == id) then ptr => entry%process_t return end if entry => entry%next end do if (associated (stack%next)) ptr => stack%next%get_process_ptr (id) end function process_stack_get_process_ptr @ %def process_stack_get_process_ptr @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[process_stacks_ut.f90]]>>= <> module process_stacks_ut use unit_tests use process_stacks_uti <> <> contains <> end module process_stacks_ut @ %def process_stacks_ut @ <<[[process_stacks_uti.f90]]>>= <> module process_stacks_uti <> use os_interface use sm_qcd use models use model_data use variables, only: var_list_t use process_libraries use rng_base use prc_test, only: prc_test_create_library use process, only: process_t use instances, only: process_instance_t use processes_ut, only: prepare_test_process use process_stacks use rng_base_ut, only: rng_test_factory_t <> <> contains <> end module process_stacks_uti @ %def process_stacks_uti @ API: driver for the unit tests below. <>= public :: process_stacks_test <>= subroutine process_stacks_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine process_stacks_test @ %def process_stacks_test @ \subsubsection{Write an empty process stack} The most trivial test is to write an uninitialized process stack. <>= call test (process_stacks_1, "process_stacks_1", & "write an empty process stack", & u, results) <>= public :: process_stacks_1 <>= subroutine process_stacks_1 (u) integer, intent(in) :: u type(process_stack_t) :: stack write (u, "(A)") "* Test output: process_stacks_1" write (u, "(A)") "* Purpose: display an empty process stack" write (u, "(A)") call stack%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: process_stacks_1" end subroutine process_stacks_1 @ %def process_stacks_1 @ \subsubsection{Fill a process stack} Fill a process stack with two (identical) processes. <>= call test (process_stacks_2, "process_stacks_2", & "fill a process stack", & u, results) <>= public :: process_stacks_2 <>= subroutine process_stacks_2 (u) integer, intent(in) :: u type(process_stack_t) :: stack type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(var_list_t) :: var_list type(process_entry_t), pointer :: process => null () write (u, "(A)") "* Test output: process_stacks_2" write (u, "(A)") "* Purpose: fill a process stack" write (u, "(A)") write (u, "(A)") "* Build, initialize and store two test processes" write (u, "(A)") libname = "process_stacks2" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call model%init_test () call var_list%append_string (var_str ("$run_id")) call var_list%append_log (var_str ("?alphas_is_fixed"), .true.) call var_list%append_int (var_str ("seed"), 0) allocate (process) call var_list%set_string & (var_str ("$run_id"), var_str ("run1"), is_known=.true.) call process%init (procname, lib, os_data, model, var_list) call stack%push (process) allocate (process) call var_list%set_string & (var_str ("$run_id"), var_str ("run2"), is_known=.true.) call process%init (procname, lib, os_data, model, var_list) call stack%push (process) call stack%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call stack%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_stacks_2" end subroutine process_stacks_2 @ %def process_stacks_2 @ \subsubsection{Fill a process stack} Fill a process stack with two (identical) processes. <>= call test (process_stacks_3, "process_stacks_3", & "process variables", & u, results) <>= public :: process_stacks_3 <>= subroutine process_stacks_3 (u) integer, intent(in) :: u type(process_stack_t) :: stack type(model_t), target :: model type(string_t) :: procname type(process_entry_t), pointer :: process => null () type(process_instance_t), target :: process_instance write (u, "(A)") "* Test output: process_stacks_3" write (u, "(A)") "* Purpose: setup process variables" write (u, "(A)") write (u, "(A)") "* Initialize process variables" write (u, "(A)") procname = "processes_test" call model%init_test () write (u, "(A)") "* Initialize process variables" write (u, "(A)") call stack%init_var_list () call stack%init_result_vars (procname) call stack%write_var_list (u) write (u, "(A)") write (u, "(A)") "* Build and integrate a test process" write (u, "(A)") allocate (process) call prepare_test_process (process%process_t, process_instance, model) call process_instance%integrate (1, 1, 1000) call process_instance%final () call process%final_integration (1) call stack%push (process) write (u, "(A)") "* Fill process variables" write (u, "(A)") call stack%fill_result_vars (procname) call stack%write_var_list (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call stack%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_stacks_3" end subroutine process_stacks_3 @ %def process_stacks_3 @ \subsubsection{Linked a process stack} Fill two process stack, linked to each other. <>= call test (process_stacks_4, "process_stacks_4", & "linked stacks", & u, results) <>= public :: process_stacks_4 <>= subroutine process_stacks_4 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(process_stack_t), target :: stack1, stack2 type(model_t), target :: model type(string_t) :: libname type(string_t) :: procname1, procname2 type(os_data_t) :: os_data type(process_entry_t), pointer :: process => null () write (u, "(A)") "* Test output: process_stacks_4" write (u, "(A)") "* Purpose: link process stacks" write (u, "(A)") write (u, "(A)") "* Initialize process variables" write (u, "(A)") libname = "process_stacks_4_lib" procname1 = "process_stacks_4a" procname2 = "process_stacks_4b" call os_data%init () write (u, "(A)") "* Initialize first process" write (u, "(A)") call prc_test_create_library (procname1, lib) call model%init_test () allocate (process) call process%init (procname1, lib, os_data, model) call stack1%push (process) write (u, "(A)") "* Initialize second process" write (u, "(A)") call stack2%link (stack1) call prc_test_create_library (procname2, lib) allocate (process) call process%init (procname2, lib, os_data, model) call stack2%push (process) write (u, "(A)") "* Show linked stacks" write (u, "(A)") call stack2%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call stack2%final () call stack1%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_stacks_4" end subroutine process_stacks_4 @ %def process_stacks_4 @