Index: trunk/ChangeLog =================================================================== --- trunk/ChangeLog (revision 8815) +++ trunk/ChangeLog (revision 8816) @@ -1,2300 +1,2303 @@ ChangeLog -- Summary of changes to the WHIZARD package Use svn log to see detailed changes. Version 3.0.2+ +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/src/qed_pdf/Makefile.am =================================================================== --- trunk/src/qed_pdf/Makefile.am (revision 8815) +++ trunk/src/qed_pdf/Makefile.am (revision 8816) @@ -1,195 +1,201 @@ ## Makefile.am -- Makefile for WHIZARD ## ## Process this file with automake to produce Makefile.in # # Copyright (C) 1999-2022 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## ## The files in this directory handle unit tests in Fortran. ## We create a library which is still to be combined with auxiliary libs. noinst_LTLIBRARIES = libqed_pdf.la +check_LTLIBRARIES = libqed_pdf_ut.la libqed_pdf_la_SOURCES = \ $(QED_MODULES) \ $(QED_SUBMODULES) QED_MODULES = \ electron_pdfs.f90 QED_SUBMODULES = \ electron_pdfs_sub.f90 +libqed_pdf_ut_la_SOURCES = \ + electron_pdfs_uti.f90 electron_pdfs_ut.f90 + ## Omitting this would exclude it from the distribution dist_noinst_DATA = qed_pdf.nw # Modules and installation # Dump module names into file Modules execmoddir = $(fmoddir)/whizard # For the moment this only installs module .mod files, not submodule files nodist_execmod_HEADERS = \ ${QED_MODULES:.f90=.$(FCMOD)} # Submodules must not be included here -libqed_pdf_Modules = ${QED_MODULES:.f90=} +libqed_pdf_Modules = ${QED_MODULES:.f90=} ${libqed_pdf_ut_la_SOURCES:.f90=} Modules: Makefile @for module in $(libqed_pdf_Modules); do \ echo $$module >> $@.new; \ done @if diff $@ $@.new -q >/dev/null; then \ rm $@.new; \ else \ mv $@.new $@; echo "Modules updated"; \ fi BUILT_SOURCES = Modules ## Fortran module dependencies # Get module lists from other directories module_lists = \ ../basics/Modules \ ../utilities/Modules \ + ../system/Modules \ + ../testing/Modules \ ../physics/Modules $(module_lists): $(MAKE) -C `dirname $@` Modules -Module_dependencies.sed: $(libqed_pdf_la_SOURCES) +Module_dependencies.sed: $(libqed_pdf_la_SOURCES) $(libqed_pdf_ut_la_SOURCES) Module_dependencies.sed: $(module_lists) @rm -f $@ echo 's/, *only:.*//' >> $@ echo 's/, *&//' >> $@ echo 's/, *.*=>.*//' >> $@ echo 's/$$/.lo/' >> $@ for list in $(module_lists); do \ dir="`dirname $$list`"; \ for mod in `cat $$list`; do \ echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \ done \ done DISTCLEANFILES = Module_dependencies.sed # The following line just says # include Makefile.depend # but in a portable fashion (depending on automake's AM_MAKE_INCLUDE @am__include@ @am__quote@Makefile.depend@am__quote@ Makefile.depend: Module_dependencies.sed -Makefile.depend: $(libqed_pdf_la_SOURCES) +Makefile.depend: $(libqed_pdf_la_SOURCES) $(libqed_pdf_ut_la_SOURCES) @rm -f $@ for src in $^; do \ module="`basename $$src | sed 's/\.f[90][0358]//'`"; \ grep '^ *use ' $$src \ | grep -v '!NODEP!' \ | sed -e 's/^ *use */'$$module'.lo: /' \ -f Module_dependencies.sed; \ done > $@ DISTCLEANFILES += Makefile.depend # Fortran90 module files are generated at the same time as object files .lo.$(FCMOD): @: # touch $@ -AM_FCFLAGS = -I../basics -I../utilities -I../system -I../combinatorics -I../physics +AM_FCFLAGS = -I../basics -I../utilities -I../testing -I../system -I../combinatorics -I../physics ######################################################################## # For the moment, the submodule dependencies will be hard-coded electron_pdfs_sub.lo: electron_pdfs.lo ######################################################################## ## Default Fortran compiler options ## Profiling if FC_USE_PROFILING AM_FCFLAGS += $(FCFLAGS_PROFILING) endif ## OpenMP if FC_USE_OPENMP AM_FCFLAGS += $(FCFLAGS_OPENMP) endif ## MPI if FC_USE_MPI AM_FCFLAGS += $(FCFLAGS_MPI) endif ######################################################################## ## Non-standard targets and dependencies ## (Re)create F90 sources from NOWEB source. if NOWEB_AVAILABLE PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw qed_pdf.stamp: $(PRELUDE) $(srcdir)/qed_pdf.nw $(POSTLUDE) @rm -f qed_pdf.tmp @touch qed_pdf.tmp - for src in $(libqed_pdf_la_SOURCES); do \ + for src in $(libqed_pdf_la_SOURCES) $(libqed_pdf_ut_la_SOURCES); do \ $(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \ done @mv -f qed_pdf.tmp qed_pdf.stamp -$(libqed_pdf_la_SOURCES): qed_pdf.stamp +$(libqed_pdf_la_SOURCES) $(libqed_pdf_ut_la_SOURCES): qed_pdf.stamp ## Recover from the removal of $@ @if test -f $@; then :; else \ rm -f qed_pdf.stamp; \ $(MAKE) $(AM_MAKEFLAGS) qed_pdf.stamp; \ fi endif ######################################################################## ## Non-standard cleanup tasks ## Remove sources that can be recreated using NOWEB if NOWEB_AVAILABLE maintainer-clean-noweb: -rm -f *.f90 *.c endif .PHONY: maintainer-clean-noweb ## Remove those sources also if builddir and srcdir are different if NOWEB_AVAILABLE clean-noweb: test "$(srcdir)" != "." && rm -f *.f90 *.c || true endif .PHONY: clean-noweb ## Remove F90 module files clean-local: clean-noweb -rm -f qed_pdf.stamp qed_pdf.tmp -rm -f *.$(FCMOD) if FC_SUBMODULES -rm -f *.smod *.sub endif ## Remove backup files maintainer-clean-backup: -rm -f *~ .PHONY: maintainer-clean-backup ## Register additional clean targets maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup Index: trunk/src/qed_pdf/qed_pdf.nw =================================================================== --- trunk/src/qed_pdf/qed_pdf.nw (revision 8815) +++ trunk/src/qed_pdf/qed_pdf.nw (revision 8816) @@ -1,299 +1,3531 @@ %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: QED ISR structure functions ("PDFs") %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{QED Parton Distribution Functions} \label{chap:qed_pdf} \includemodulegraph{qed_pdf} We start with a module that gives access to the ISR structure function: \begin{description} \item[electron\_pdfs] \end{description} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Electron PDFs} This module contains the formulae for the numerical evaluation of different incarnations of the QED initial-state radiation (ISR) structure functions (a.k.a. electron PDFs). <<[[electron_pdfs.f90]]>>= <> module electron_pdfs <> <> <> <> +<> + <> interface <> end interface +contains + +<> + end module electron_pdfs @ %def electron_pdfs @ <>= use io_units + use sm_qed @ %def electron_pdfs use @ <<[[electron_pdfs_sub.f90]]>>= <> submodule (electron_pdfs) electron_pdfs_s <> <> - use constants, only: pi - use format_defs, only: FMT_19 + use diagnostics + use constants + use format_defs, only: FMT_12 use numeric_utils - use sm_physics, only: Li2, zeta2, zeta3 + use physics_defs + use sm_physics implicit none contains <> end submodule electron_pdfs_s @ \subsection{The physics for electron beam PDFs (structure functions)} The ISR structure function is in the most crude approximation (LLA without $\alpha$ corrections, i.e. $\epsilon^0$) \begin{equation} f_0(x) = \epsilon (1-x)^{-1+\epsilon} \qquad\text{with}\qquad \epsilon = \frac{\alpha}{\pi}q_e^2\ln\frac{s}{m^2}, \end{equation} where $m$ is the mass of the incoming (and outgoing) particle, which is initially assumed on-shell. Here, the form of $\epsilon$ results from the kinematical bounds for the momentum squared of the outgoing particle, which in the limit $m^2\ll s$ are given by \begin{align} t_0 &= -2\bar xE(E+p) + m^2 \approx -\bar x s, \\ t_1 &= -2\bar xE(E-p) + m^2 \approx x m^2, \end{align} so the integration over the propagator $1/(t-m^2)$ yields \begin{equation} \ln\frac{t_0-m^2}{t_1-m^2} = \ln\frac{s}{m^2}. \end{equation} The structure function has three parameters: $\alpha$, $m_{\rm in}$ of the incoming particle and $s$, the hard scale. Internally, we store the exponent $\epsilon$ which is the relevant parameter. (In conventional notation, $\epsilon=\beta/2$.) As defaults, we take the actual values of $\alpha$ (which is probably $\alpha(s)$), the actual mass $m_{\rm in}$ and the squared total c.m. energy $s$. Including $\epsilon$, $\epsilon^2$, and $\epsilon^3$ corrections, the successive approximation of the ISR structure function read \begin{align} f_0(x) &= \epsilon(1-x)^{-1+\epsilon} \\ f_1(x) &= g_1(\epsilon)\,f_0(x) - \frac{\epsilon}{2}(1+x) \\ \begin{split} f_2(x) &= g_2(\epsilon)\,f_0(x) - \frac{\epsilon}{2}(1+x) \\ &\quad - \frac{\epsilon^2}{8}\left( \frac{1+3x^2}{1-x}\ln x + 4(1+x) \ln(1-x) + 5 + x \right) \end{split} \\ \begin{split} f_3(x) &= g_3(\epsilon)\,f_0(x) - \frac{\epsilon}{2}(1+x) \\ &\quad - \frac{\epsilon^2}{8}\left( \frac{1+3x^2}{1-x}\ln x + 4(1+x) \ln(1-x) + 5 + x \right) \\ &\quad - \frac{\epsilon^3}{48}\left( \vphantom{\frac{1}{1-x}} (1+x)\left[6\mathop{\rm Li_2}(x) + 12\ln^2(1-x) - 3\pi^2\right]\right. + 6(x+5)\ln(1-x) \\ &\qquad\qquad + \frac{1}{1-x}\left[\frac32(1+8x+3x^2)\ln x + 12(1+x^2)\ln x\ln(1-x) \right. \\ &\qquad\qquad\qquad\qquad \left.\left. - \frac12(1+7x^2)\ln^2x + \frac14(39-24x-15x^2)\right] \vphantom{\frac{1}{1-x}} \right) \end{split} \end{align} where the successive approximations to the prefactor of the leading singularity \begin{equation} g(\epsilon) = \frac{\exp\left(\epsilon(-\gamma_E + \tfrac34)\right)} {\Gamma(1 + \epsilon)}, \end{equation} are given by \begin{align} g_0(\epsilon) &= 1 \\ g_1(\epsilon) &= 1 + \frac34\epsilon \\ g_2(\epsilon) &= 1 + \frac34\epsilon + \frac{27 - 8\pi^2}{96}\epsilon^2 \\ g_3(\epsilon) &= 1 + \frac34\epsilon + \frac{27 - 8\pi^2}{96}\epsilon^2 + \frac{27 - 24\pi^2 + 128 \zeta(3)}{384}\epsilon^3, \end{align} where, numerically \begin{equation} \zeta(3) = 1.20205690315959428539973816151\ldots \end{equation} Although one could calculate the function $g(\epsilon)$ exactly, truncating its Taylor expansion ensures the exact normalization of the truncated structure function at each given order: \begin{equation} \int_0^1 dx\,f_i(x) = 1 \qquad\text{for all $i$.} \end{equation} Effectively, the $O(\epsilon)$ correction reduces the low-$x$ tail of the structure function by $50\%$ while increasing the coefficient of the singularity by $O(\epsilon)$. Relative to this, the $O(\epsilon^2)$ correction slightly enhances $x>\frac12$ compared to $x<\frac12$. At $x=0$, $f_2(x)$ introduces a logarithmic singularity which should be cut off at $x_0=O(e^{-1/\epsilon})$: for lower $x$ the perturbative series breaks down. The $f_3$ correction is slightly positive for low $x$ values and negative near $x=1$, where the $\mathop{\rm Li_2}$ piece slightly softens the singularity at $x=1$. Instead of the definition for $\epsilon$ given above, it is customary to include a universal nonlogarithmic piece: \begin{equation} \epsilon = \frac{\alpha}{\pi}q_e^2\left(\ln\tfrac{s}{m^2} - 1\right) \end{equation} \subsection{Implementation} The basic type for lepton beam (QED) structure functions: <>= public :: qed_pdf_t <>= type :: qed_pdf_t private integer :: flv = 0 + class(alpha_qed_t), allocatable :: aqed real(default) :: mass = 0 real(default) :: q_max = 0 real(default) :: alpha = 0 real(default) :: eps = 0 + real(default), allocatable :: q_in integer :: order + integer :: log_order + integer :: n_lep contains <> end type qed_pdf_t @ %def qed_pdf_t @ +<>= + integer, parameter, public :: EPDF_ELE = 0, EPDF_POS = 1, & + EPDF_S = 2, EPDF_NS = 3, EPDF_G = 4 + +@ %def EPDF_ELE EPDF_POS EPDF_S EPDF_NS EPDF_G +@ <>= procedure :: init => qed_pdf_init <>= module subroutine qed_pdf_init & - (qed_pdf, mass, alpha, charge, q_max, order) + (qed_pdf, mass, alpha, charge, q_max, order, log_order, n_lep) class(qed_pdf_t), intent(out) :: qed_pdf real(default), intent(in) :: mass, alpha, q_max, charge - integer, intent(in) :: order + integer, intent(in) :: order, log_order, n_lep end subroutine qed_pdf_init <>= module subroutine qed_pdf_init & - (qed_pdf, mass, alpha, charge, q_max, order) + (qed_pdf, mass, alpha, charge, q_max, order, log_order, n_lep) class(qed_pdf_t), intent(out) :: qed_pdf real(default), intent(in) :: mass, alpha, q_max, charge - integer, intent(in) :: order + integer, intent(in) :: order, log_order, n_lep qed_pdf%mass = mass qed_pdf%q_max = q_max qed_pdf%alpha = alpha - qed_pdf%order = order + qed_pdf%order = order + qed_pdf%log_order = log_order + qed_pdf%n_lep = n_lep qed_pdf%eps = alpha/pi * charge**2 & - * (2 * log (q_max / mass) - 1) + * (2 * log (q_max / mass) - 1) end subroutine qed_pdf_init @ %def qed_pdf_init @ Write routine. <>= procedure :: write => qed_pdf_write <>= - module subroutine qed_pdf_write (qed_pdf, unit) + module subroutine qed_pdf_write (qed_pdf, unit, with_qed) class(qed_pdf_t), intent(in) :: qed_pdf integer, intent(in), optional :: unit - integer :: u + logical, intent(in), optional :: with_qed end subroutine qed_pdf_write <>= - module subroutine qed_pdf_write (qed_pdf, unit) + module subroutine qed_pdf_write (qed_pdf, unit, with_qed) class(qed_pdf_t), intent(in) :: qed_pdf integer, intent(in), optional :: unit + logical, intent(in), optional :: with_qed integer :: u + logical :: show_qed u = given_output_unit (unit) + show_qed = .false. + if (present (with_qed)) show_qed = with_qed write (u, "(3x,A)") "QED structure function (PDF):" write (u, "(5x,A,I0)") "Flavor = ", qed_pdf%flv - write (u, "(5x,A," // FMT_19 // ")") "Mass = ", qed_pdf%mass - write (u, "(5x,A," // FMT_19 // ")") "q_max = ", qed_pdf%q_max - write (u, "(5x,A," // FMT_19 // ")") "alpha = ", qed_pdf%alpha - write (u, "(5x,A,I0)") "Order = ", qed_pdf%order - write (u, "(5x,A," // FMT_19 // ")") "epsilon = ", qed_pdf%eps + write (u, "(5x,A," // FMT_12 // ")") "Mass = ", qed_pdf%mass + write (u, "(5x,A," // FMT_12 // ")") "q_max = ", qed_pdf%q_max + write (u, "(5x,A," // FMT_12 // ")") "alpha = ", qed_pdf%alpha + write (u, "(5x,A,I0)") "Order = ", qed_pdf%order + write (u, "(5x,A,I0)") "Log. ord. = ", qed_pdf%log_order + write (u, "(5x,A,I0)") "# leptons = ", qed_pdf%n_lep + write (u, "(5x,A," // FMT_12 // ")") "epsilon = ", qed_pdf%eps + if (show_qed) then + call qed_pdf%aqed%write (u) + end if end subroutine qed_pdf_write @ %def qed_pdf_write @ For some unit tests, the order has to be set explicitly. <>= procedure :: set_order => qed_pdf_set_order <>= module subroutine qed_pdf_set_order (qed_pdf, order) class(qed_pdf_t), intent(inout) :: qed_pdf integer, intent(in) :: order end subroutine qed_pdf_set_order <>= module subroutine qed_pdf_set_order (qed_pdf, order) class(qed_pdf_t), intent(inout) :: qed_pdf integer, intent(in) :: order qed_pdf%order = order end subroutine qed_pdf_set_order @ %def qed_pdf_set_order @ Calculate the actual value depending on the order and a possible mapping parameter. <>= procedure :: evolve_qed_pdf => qed_pdf_evolve_qed_pdf <>= module subroutine qed_pdf_evolve_qed_pdf (qed_pdf, x, xb, rb, ff) class(qed_pdf_t), intent(inout) :: qed_pdf real(default), intent(in) :: x, xb, rb real(default), intent(inout) :: ff end subroutine qed_pdf_evolve_qed_pdf <>= module subroutine qed_pdf_evolve_qed_pdf (qed_pdf, x, xb, rb, ff) class(qed_pdf_t), intent(inout) :: qed_pdf real(default), intent(in) :: x, xb, rb real(default), intent(inout) :: ff real(default), parameter :: & & xmin = 0.00714053329734592839549879772019_default real(default), parameter :: & g1 = 3._default / 4._default, & g2 = (27 - 8 * pi**2) / 96._default, & g3 = (27 - 24 * pi**2 + 128 * zeta3) / 384._default real(default) :: x_2, log_x, log_xb if (ff > 0 .and. qed_pdf%order > 0) then ff = ff * (1 + g1 * qed_pdf%eps) x_2 = x * x if (rb > 0) ff = ff * (1 - (1-x_2) / (2 * rb)) if (qed_pdf%order > 1) then ff = ff * (1 + g2 * qed_pdf%eps**2) if (rb > 0 .and. xb > 0 .and. x > xmin) then log_x = log_prec (x, xb) log_xb = log_prec (xb, x) ff = ff * (1 - ((1 + 3 * x_2) * log_x + xb * (4 * (1 + x) * & log_xb + 5 + x)) / (8 * rb) * qed_pdf%eps) end if if (qed_pdf%order > 2) then ff = ff * (1 + g3 * qed_pdf%eps**3) if (rb > 0 .and. xb > 0 .and. x > xmin) then ff = ff * (1 - ((1 + x) * xb & * (6 * Li2(x) + 12 * log_xb**2 - 3 * pi**2) & + 1.5_default * (1 + 8 * x + 3 * x_2) * log_x & + 6 * (x + 5) * xb * log_xb & + 12 * (1 + x_2) * log_x * log_xb & - (1 + 7 * x_2) * log_x**2 / 2 & + (39 - 24 * x - 15 * x_2) / 4) & / (48 * rb) * qed_pdf%eps**2) end if end if end if end if end subroutine qed_pdf_evolve_qed_pdf @ %def qed_pdf_evolve_qed_pdf +@ Gfortran 7/8/9 bug, has to remain in the main module: +<>= + procedure :: allocate_aqed => qed_pdf_allocate_aqed +<>= + subroutine qed_pdf_allocate_aqed (qed, order, n_f, n_lep, running) + class(qed_pdf_t), intent(inout) :: qed + integer, intent(in) :: order, n_f, n_lep + logical, intent(in) :: running + if (running) then + allocate (alpha_qed_from_scale_t :: qed%aqed) + select type (aqed => qed%aqed) + type is (alpha_qed_from_scale_t) + aqed%order = order + aqed%nf = n_f + aqed%nlep = n_lep + end select + else + allocate (alpha_qed_fixed_t :: qed%aqed) + end if + end subroutine qed_pdf_allocate_aqed + +@ %def qed_pdf_allocate_qed +@ Part for the singlet- and non-singlet contributions of the PDF. +<>= + public :: elec_asym +<>= + module function elec_asym (epdf, x, scale, alpha, running) result (elec_as) + type(qed_pdf_t), intent(in) :: epdf + real(default) :: elec_as + real(default), intent(in) :: x + real(default), intent(in) :: scale + real(default), intent(in) :: alpha + logical, intent(in) :: running + end function elec_asym +<>= + module function elec_asym (epdf, x, scale, alpha, running) result (elec_as) + type(qed_pdf_t), intent(in) :: epdf + real(default) :: elec_as + real(default), intent(in) :: x + real(default), intent(in) :: scale + real(default), intent(in) :: alpha + logical, intent(in) :: running + real(default) :: lambda0, lambda1, xi1, xihat1, fac + real(default) :: al0_2pi, al2pi, ca, cb, psixi1 + real(default) :: ln0, eta0, t, xi0, b0, b1 + integer :: nf, nlep + lambda0 = 3._default/4._default + al0_2pi = alpha / two / Pi + if (allocated (epdf%q_in)) then + ln0 = log(epdf%q_in**2/epdf%mass**2) + eta0 = alpha/Pi * log(scale**2/epdf%q_in**2) + else + ln0 = zero + eta0 = alpha/Pi * log(scale**2/epdf%mass**2) + end if + if (running) then + t = t_alpha (epdf, scale) + xi0 = two*t + else + xi0 = eta0 + end if + select case (epdf%log_order) + case (EPDF_LL) + elec_as = exp((lambda0 - eulerc) * xi0) / gamma (one + xi0) * & + xi0 * (1 - x)**(-one + xi0) + case (EPDF_NLL) + lambda1 = 3._default/8._default - Pi2/two + 6._default*zeta3 - & + epdf%n_lep/18._default * (three + four*Pi2) + if (running) then + select type (aqed => epdf%aqed) + type is (alpha_qed_from_scale_t) + nf = aqed%nf + nlep = aqed%nlep + al2pi = aqed%get (scale) / two / Pi + type is (alpha_qed_fixed_t) + call msg_fatal & + ("elec_asym: has to be called with running alpha.") + end select + b0 = coeffqed_b0(nf,nlep) + b1 = coeffqed_b1(nf,nlep) + xi1 = xi0 + al2pi / two / Pi / b0 * (one - exp (Pi * b0 * xi0)) * & + (20._default/9._default * epdf%n_lep + four * Pi * b1 / b0) + xihat1 = xi0 * lambda0 - al2pi / two / Pi / b0 * & + (one - exp (Pi * b0 * xi0)) * (lambda1 - three * Pi * b1 / b0) + else + al2pi = al0_2pi + xi1 = xi0 * ( one - 10._default/9._default * al2pi * epdf%n_lep) + xihat1 = xi0 * ( lambda0 + al2pi/two * lambda1 ) + end if + fac = exp( xihat1 - eulerc * xi1 ) / gamma (1 + xi1) * & + xi1 * (1 - x)**(-one + xi1) + psixi1 = psir(xi1) + ca = - eulerc - psixi1 + cb = 0.5_default * eulerc**2 + Pi2/12. + eulerc*psixi1 + & + 0.5_default * psixi1**2 - 0.5_default * psimr(xi1,1) + elec_as = fac * (one + two*al0_2pi * & + ( (ln0 - one)*( ca + 3._default/4._default ) - & + 2*cb + 7._default/4._default + & + (ln0 - one - two*ca)*log(1-x) - log(1-x)**2 )) + case default + elec_as = 0 + end select + end function elec_asym + +@ %defe elec_asym +@ Photon component of the PDF. +<>= + public :: phot_asym +<>= + module function phot_asym & + (epdf, x, scale, alpha, nlep, running) result (phot_as) + type(qed_pdf_t), intent(in) :: epdf + real(default) :: phot_as + real(default), intent(in) :: x + real(default), intent(in) :: scale + real(default), intent(in) :: alpha + integer, intent(in) :: nlep + logical, intent(in) :: running + end function phot_asym +<>= + module function phot_asym & + (epdf, x, scale, alpha, nlep, running) result (phot_as) + type(qed_pdf_t), intent(in) :: epdf + real(default) :: phot_as + real(default), intent(in) :: x + real(default), intent(in) :: scale + real(default), intent(in) :: alpha + integer, intent(in) :: nlep + logical, intent(in) :: running + real(default) :: ln0, eta0, t, xi0, xihat0, den + real(default) :: al0_2pi, c_b0, c_b1ob0 + real(default) :: lambda1, xi10, xihat10 + real(default) :: chi10, mf1k, mf10 + real(default) :: gam1, gam2, gam3, gam4, gam5 + real(default) :: d11, d21, d12, d22, d13, d23, d14, d24 + real(default) :: c11, c21, c31, c12, c22, c32, c13, c23, c33, & + c14, c24, c34, k1, k2, k3, k4 + al0_2pi = alpha / two / Pi + if (allocated (epdf%q_in)) then + ln0 = log(epdf%q_in**2/epdf%mass**2) + eta0 = alpha/Pi * log(scale**2/epdf%q_in**2) + else + ln0 = zero + eta0 = alpha/Pi * log(scale**2/epdf%mass**2) + end if + if (running) then + c_b0 = - coeffqed_b0 (0, nlep) + c_b1ob0 = coeffqed_b1 (0, nlep) / coeffqed_b0 (0, nlep) + t = t_alpha (epdf, scale) + chi10 = zero + else + c_b0 = zero + c_b1ob0 = zero + t = eta0 / two + chi10 = al0_2pi * nlep + end if + select case (epdf%log_order) + case (EPDF_LL) + xi0 = two * t + xihat0 = three * t / two + den = -two/three * nlep - three/two - two * log(1-x) + mf1k = exp(-eulerc * xi0) * (1-x)**xi0 / gamma(1+xi0) * & + (one / den - (Pi2*xi0 - 6._default * zeta3 * xi0**2) / & + three / den**2 - (30._default * Pi2 - 360._default * & + zeta3 * xi0 + Pi**4 * xi0**2) / 45._default / den**3) + mf10 = one / den - 2._default * Pi2 / three / den**3 + phot_as = - exp(xihat0) * mf1k + & + exp(-two/three * nlep * t) * mf10 + case (EPDF_NLL) + lambda1 = three/8._default - Pi2/two + 6._default*zeta3 - & + nlep/18._default * (three + four*Pi2) + xi10 = two - four*al0_2pi * (5._default/9._default * nlep + Pi*c_b1ob0) + xihat10 = three/two * ( one + al0_2pi * two * & + (lambda1/three - Pi * c_b1ob0)) + d11 = xi10 + d21 = - (two/three * nlep + two * Pi * c_b0 + xihat10 + chi10) + c11 = al0_2pi * exp(-D21*t) + c21 = - al0_2pi * (five + four/three * nlep) * exp(-d21*t) + c31 = al0_2pi * (6._default + Pi2/6._default + 32._default/9._default * & + nlep + two * Pi * c_b1ob0) * exp(-d21*t) + d12 = d11 + d22 = d21 + c12 = - al0_2pi + c22 = al0_2pi * (5._default + four/three * nlep) + c32 = - al0_2pi * (6._default + Pi2/6._default + & + 32._default/9._default * nlep + two *Pi *c_b1ob0) + d13 = d11 + d23 = - (two/three * nlep + xihat10 + chi10) + c13 = zero + c23 = zero + c33 = - exp(-d23*t) + d14 = d13 + d24 = d23 + c14 = zero + c24 = zero + c34 = one + k1 = xi10 * t + k2 = zero + k3 = xi10 * t + k4 = zero + gam1 = sum_rm (x, al0_2pi, ln0, & + c11, c21, c31, d21/d11, d11, k1, d11, d21) + gam2 = sum_rm (x, al0_2pi, ln0, & + c12, c22, c32, d22/d12, d12, k2, d12, d22) + gam3 = sum_rm (x, al0_2pi, ln0, & + c13, c23, c33, d23/d13, d13, k3, d13, d23) + gam4 = sum_rm (x, al0_2pi, ln0, & + c14, c24, c34, d24/d14, d14, k4, d14, d24) + gam5 = al0_2pi * (one + (1-x)**2)/x * (ln0 - two*log(x) - one) + phot_as = exp( - ( two/three * nlep + chi10 ) * t ) * & + (gam1 + gam2 + gam3 + gam4 + gam5) + end select + end function phot_asym + +@ %def phot_asym +@ +<>= + public :: bar_asym +<>= + module function bar_asym & + (epdf, flv, x, scale, alpha, running) result (bar_as) + type(qed_pdf_t), intent(in) :: epdf + integer, intent(in) :: flv + real(default) :: bar_as + real(default), intent(in) :: x + real(default), intent(in) :: scale + real(default), intent(in) :: alpha + logical, intent(in) :: running + end function bar_asym +<>= + module function bar_asym & + (epdf, flv, x, scale, alpha, running) result (bar_as) + type(qed_pdf_t), intent(in) :: epdf + integer, intent(in) :: flv + real(default) :: bar_as + real(default), intent(in) :: x + real(default), intent(in) :: scale + real(default), intent(in) :: alpha + logical, intent(in) :: running + logical, dimension(6) :: order + integer :: nlep + real(default) :: ln0, eta0, al_2pi, p + real(default), dimension(6) :: jll_nll + if (allocated (epdf%q_in)) then + ln0 = log(epdf%q_in**2/epdf%mass**2) + eta0 = alpha/Pi * log(scale**2/epdf%q_in**2) + else + ln0 = zero + eta0 = alpha/Pi * log(scale**2/epdf%mass**2) + end if + if (running) then + p = t_alpha (epdf, scale) + else + p = eta0 / two + end if + order = .false. + order(1:3) = .true. + select case (epdf%log_order) + case (EPDF_LL) + nlep = epdf%n_lep + al_2pi = zero + case (EPDF_NLL) + if (running) then + select type (aqed => epdf%aqed) + type is (alpha_qed_from_scale_t) + nlep = aqed%nlep + al_2pi = aqed%get (scale) / two / Pi + type is (alpha_qed_fixed_t) + call msg_fatal & + ("bar_asym: has to be called with running alpha.") + end select + else + nlep = epdf%n_lep + al_2pi = alpha / two / Pi + end if + order(4:6) = .true. + end select + select case (flv) + case (EPDF_ELE,EPDF_POS,EPDF_S,EPDF_NS) + call elecbar_asym_p (x, jll_nll, nlep, ln0, order, running) + case (EPDF_G) + call photbar_asym_p (x, jll_nll, nlep, ln0, order, running) + case default + call msg_fatal & + ("bar_asym: wrong lepton flavor.") + end select + bar_as = rec_series (p, al_2pi, jll_nll) + end function bar_asym + +@ %def bar_asym +@ +<>= + public :: rec_num +<>= + module function rec_num & + (epdf, flv, x, scale, alpha, running) result (recnum) + type(qed_pdf_t), intent(in) :: epdf + integer, intent(in) :: flv + real(default) :: recnum + real(default), intent(in) :: x + real(default), intent(in) :: scale + real(default), intent(in) :: alpha + logical, intent(in) :: running + end function rec_num +<>= + module function rec_num & + (epdf, flv, x, scale, alpha, running) result (recnum) + type(qed_pdf_t), intent(in) :: epdf + integer, intent(in) :: flv + real(default) :: recnum + real(default), intent(in) :: x + real(default), intent(in) :: scale + real(default), intent(in) :: alpha + logical, intent(in) :: running + integer :: nlep + real(default) :: ln0, eta0, al_2pi, p, prefac + if (allocated (epdf%q_in)) then + ln0 = log(epdf%q_in**2/epdf%mass**2) + eta0 = alpha/Pi * log(scale**2/epdf%q_in**2) + else + ln0 = zero + eta0 = alpha/Pi * log(scale**2/epdf%mass**2) + end if + if (running) then + p = t_alpha (epdf, scale) + else + p = eta0 / two + end if + select case (epdf%log_order) + case (EPDF_LL) + recnum = 0 + return + case (EPDF_NLL) + if (running) then + select type (aqed => epdf%aqed) + type is (alpha_qed_from_scale_t) + nlep = aqed%nlep + al_2pi = aqed%get (scale) / two / Pi + type is (alpha_qed_fixed_t) + call msg_fatal & + ("bar_asym: has to be called with running alpha.") + end select + else + nlep = epdf%n_lep + al_2pi = alpha / two / Pi + end if + prefac = al_2pi * p**2 / two + end select + select case (flv) + case (EPDF_S) + recnum = prefac * endpoint_func_S (x, nlep) + case (EPDF_NS) + recnum = prefac * endpoint_func_NS (x) + case (EPDF_G) + recnum = prefac * endpoint_func_GAM (x) + case default + call msg_fatal & + ("rec_num: wrong lepton flavor.") + end select + end function rec_num + +@ %def rec_num @ +<>= + public :: recbar +<>= + module function recbar & + (epdf, flv, x, scale, alpha, running) result (bar) + type(qed_pdf_t), intent(in) :: epdf + integer, intent(in) :: flv + real(default) :: bar + real(default), intent(in) :: x + real(default), intent(in) :: scale + real(default), intent(in) :: alpha + logical, intent(in) :: running + end function recbar +<>= + module function recbar & + (epdf, flv, x, scale, alpha, running) result (bar) + type(qed_pdf_t), intent(in) :: epdf + integer, intent(in) :: flv + real(default) :: bar + real(default), intent(in) :: x + real(default), intent(in) :: scale + real(default), intent(in) :: alpha + logical, intent(in) :: running + logical, dimension(6) :: order + integer :: nlep + real(default) :: ln0, eta0, al_2pi, p + real(default), dimension(6) :: jll_nll + if (allocated (epdf%q_in)) then + ln0 = log(epdf%q_in**2/epdf%mass**2) + eta0 = alpha/Pi * log(scale**2/epdf%q_in**2) + else + ln0 = zero + eta0 = alpha/Pi * log(scale**2/epdf%mass**2) + end if + if (running) then + p = t_alpha (epdf, scale) + else + p = eta0 / two + end if + order = .false. + order(1:3) = .true. + select case (epdf%log_order) + case (EPDF_LL) + nlep = epdf%n_lep + al_2pi = zero + case (EPDF_NLL) + if (running) then + select type (aqed => epdf%aqed) + type is (alpha_qed_from_scale_t) + nlep = aqed%nlep + al_2pi = aqed%get (scale) / two / Pi + type is (alpha_qed_fixed_t) + call msg_fatal & + ("recbar: has to be called with running alpha.") + end select + else + nlep = epdf%n_lep + al_2pi = alpha / two / Pi + end if + order(4:6) = .true. + end select + select case (flv) + case (EPDF_S) + call recbar_singlet (x, jll_nll, nlep, ln0, order, running) + case (EPDF_G) + call recbar_photon (x, jll_nll, nlep, ln0, order, running) + case (EPDF_NS) + call recbar_nonsinglet (x, jll_nll, nlep, ln0, order, running) + case default + call msg_fatal & + ("recbar: wrong lepton flavor.") + end select + bar = rec_series (p, al_2pi, jll_nll) + end function recbar + +@ %def recbar +<>= + public :: rechat +<>= + module function rechat & + (epdf, flv, x, scale, alpha, running) result (hat) + type(qed_pdf_t), intent(in) :: epdf + integer, intent(in) :: flv + real(default) :: hat + real(default), intent(in) :: x + real(default), intent(in) :: scale + real(default), intent(in) :: alpha + logical, intent(in) :: running + end function rechat +<>= + module function rechat & + (epdf, flv, x, scale, alpha, running) result (hat) + type(qed_pdf_t), intent(in) :: epdf + integer, intent(in) :: flv + real(default) :: hat + real(default), intent(in) :: x + real(default), intent(in) :: scale + real(default), intent(in) :: alpha + logical, intent(in) :: running + logical, dimension(6) :: order + integer :: nlep + real(default) :: ln0, eta0, al_2pi, p + real(default), dimension(6) :: jll_nll + if (allocated (epdf%q_in)) then + ln0 = log(epdf%q_in**2/epdf%mass**2) + eta0 = alpha/Pi * log(scale**2/epdf%q_in**2) + else + ln0 = zero + eta0 = alpha/Pi * log(scale**2/epdf%mass**2) + end if + if (running) then + p = t_alpha (epdf, scale) + else + p = eta0 / two + end if + order = .false. + order(1:3) = .true. + select case (epdf%log_order) + case (EPDF_LL) + nlep = epdf%n_lep + al_2pi = zero + case (EPDF_NLL) + if (running) then + select type (aqed => epdf%aqed) + type is (alpha_qed_from_scale_t) + nlep = aqed%nlep + al_2pi = aqed%get (scale) / two / Pi + type is (alpha_qed_fixed_t) + call msg_fatal & + ("recbar: has to be called with running alpha.") + end select + else + nlep = epdf%n_lep + al_2pi = alpha / two / Pi + end if + order(4:6) = .true. + end select + select case (flv) + case (EPDF_S) + call rechat_singlet (x, jll_nll, nlep, ln0, order, running) + case (EPDF_G) + call rechat_photon (x, jll_nll, nlep, ln0, order, running) + case (EPDF_NS) + call rechat_nonsinglet (x, jll_nll, nlep, ln0, order, running) + case default + call msg_fatal & + ("rechat: wrong lepton flavor.") + end select + hat = rec_series (p, al_2pi, jll_nll) + end function rechat + +@ %def rechat +@ The logical array [[order]] allows to individually switch the +expansion terms on and off. For LL, the first three are taken, for NLL +all of them. +<>= + public :: elecbar_asym_p +<>= + module subroutine elecbar_asym_p (x, jll_nll, nlep, ln0, order, running) + real(default), intent(in) :: x + real(default), dimension(6), intent(out) :: jll_nll + real(default), intent(in) :: ln0 + integer, intent(in) :: nlep + logical, dimension(6), intent(in) :: order + logical, intent(in) :: running + end subroutine elecbar_asym_p +<>= + module subroutine elecbar_asym_p (x, jll_nll, nlep, ln0, order, running) + real(default), intent(in) :: x + real(default), dimension(6), intent(out) :: jll_nll + real(default), intent(in) :: ln0 + integer, intent(in) :: nlep + logical, dimension(6), intent(in) :: order + logical, intent(in) :: running + real(default) :: c_b0, c_b1 + jll_nll = 0._default + c_b0 = - coeffqed_b0 (0, nlep) + c_b1 = - coeffqed_b1 (0, nlep) + if (order(1)) then + jll_nll(1) = two/(one - x) + end if + if (order(2)) then + jll_nll(2) = (two*(-three - four*log(1-x))) / (-one + x) + end if + if (order(3)) then + jll_nll(3) = (-27._default + 8._default*Pi2 - 72._default*log(1-x) & + - 48*log(1-x)**2) / (two*(-one + x)) + end if + if (order(4)) then + jll_nll(4) = (two*(-one + ln0)) / (one-x) - & + (four*log(1-x))/(one-x) + end if + if (order(5)) then + if (running) then + jll_nll(5) = (one - 20._default * nlep/9._default + four*c_b0*Pi & + - (four*c_b1*Pi)/c_b0 + (four*Pi2)/three + & + ln0*(6._default-four*c_b0*Pi))/(one-x) - (two*(7._default - & + four*ln0 - four*c_b0*Pi)*log(1-x))/(one-x) - & + (12._default*log(1-x)**2)/(one-x) + else + jll_nll(5) = (one + 6._default*ln0 - (20._default * nlep)/9._default & + + (four*Pi2)/three)/(one-x) - (two*(7._default-four*ln0) * & + log(1-x))/(one-x) - (12._default*log(1-x)**2)/(one-x); + end if + end if + if (order(6)) then + if (running) then + jll_nll(6) = two * (-(((8.5_default + (80._default*nlep)/9._default - & + 28._default*c_b0*Pi + (16._default*c_b1*Pi)/c_b0 & + - (20._default*Pi2)/three + 8._default*c_b0**2*Pi2 - & + two*ln0*(9._default - 8._default*c_b0*Pi))*log(1-x))/(one-x)) - & + (6._default*(five - two*ln0 - four*c_b0*Pi) * log(1-x)**2) / & + (one-x) - (16._default*log(1-x)**3) / (one-x) + (4.5_default - & + (12._default*c_b1*Pi)/c_b0 - four*c_b0**2*Pi2 + (three + & + four*c_b1)*Pi2 - nlep*(11._default/3._default - & + (20._default*c_b0*Pi)/9._default + (four*Pi2)/9._default) - & + (two*c_b0*Pi*(three + four*Pi2))/three + ln0*(6.75_default - & + 12._default*c_b0*Pi - two*Pi2 + four*c_b0**2*Pi2) - & + 20._default*zeta3) / (one-x)) + else + jll_nll(6) = two * (-(((8.5_default - 18._default*ln0 + (80._default & + * nlep)/9._default - (20._default*Pi2)/three) * log(1-x))/(one-x)) - & + (6._default*(five-two*ln0) * log(1-x)**2)/(one-x) - & + (16._default*log(1-x)**3)/(one-x) + (4.5_default + three*Pi2 + & + ln0*(6.75_default - two*Pi2) - nlep*(11._default/3._default + & + (four*Pi2)/9._default) - 20._default*zeta3) / (one-x)) + end if + end if + end subroutine elecbar_asym_p + +@ %def elecbar_asym +@ +<>= + public :: photbar_asym_p +<>= + module subroutine photbar_asym_p (x, jll_nll, nlep, ln0, order, running) + real(default), intent(in) :: x + real(default), dimension(6), intent(out) :: jll_nll + real(default), intent(in) :: ln0 + integer, intent(in) :: nlep + logical, dimension(6), intent(in) :: order + logical, intent(in) :: running + end subroutine photbar_asym_p +<>= + module subroutine photbar_asym_p (x, jll_nll, nlep, ln0, order, running) + real(default), intent(in) :: x + real(default), dimension(6), intent(out) :: jll_nll + real(default), intent(in) :: ln0 + integer, intent(in) :: nlep + logical, dimension(6), intent(in) :: order + logical, intent(in) :: running + real(default) :: c_b0, c_b1ob0 + jll_nll = 0._default + if (running) then + c_b0 = - coeffqed_b0 (0, nlep) + c_b1ob0 = coeffqed_b1 (0, nlep) / coeffqed_b0 (0, nlep) + else + c_b0 = zero + c_b1ob0 = zero + end if + if (order(1)) then + jll_nll(1) = one + end if + if (order(2)) then + jll_nll(2) = 1.5_default - (two * nlep)/three +two*log(1-x) + end if + if (order(3)) then + jll_nll(3) = 2.25_default - nlep + four * nlep**2 / 9._default - & + (two*Pi2)/three + (6._default - (four*nlep)/three)*log(1-x) + & + four*log(1-x)**2 + end if + if (order(4)) then + jll_nll(4) = -one + ln0 + end if + if (order(5)) then + jll_nll(5) = -four + (three*ln0)/two - (two*(13._default + & + three*ln0)*nlep)/9._default - two*c_b1ob0*Pi - 2*c_b0*(-one + & + ln0)*Pi + (-7._default + two*ln0 - (four*nlep)/three)*log(1-x) & + - three*log(1-x)**2 + end if + if (order(6)) then + jll_nll(6) = -5.625_default - (23._default * nlep)/6._default + & + (52._default * nlep**2)/27._default + four*c_b0*Pi - & + 6._default*c_b1ob0*Pi + (40._default*c_b0*nlep*Pi)/9._default + & + (8._default*c_b1ob0*nlep*Pi)/three + (11._default*Pi2)/6._default & + - four*c_b0**2*Pi2 + four*c_b0*c_b1ob0*Pi2 + & + (two*nlep*Pi2)/9._default + ln0*(2.25_default + & + (four*nlep**2)/9._default - 6._default*c_b0*Pi - (two*Pi2)/three + & + four*c_b0**2*Pi2 + nlep*(-one + (8._default*c_b0*Pi)/three)) + & + (-18.5_default + (8._default*nlep**2)/9._default + & + 18._default*c_b0*Pi - 8._default*c_b1ob0*Pi + two*Pi2 + & + ln0*(6._default - (four*nlep)/three - 8._default*c_b0*Pi) + & + (four*nlep*(-5._default + two*c_b0*Pi))/three)*log(1-x) + & + (-18.5_default + four*ln0 - (two*nlep)/three + & + 10._default*c_b0*Pi)*log(1-x)**2 - 6._default*log(1-x)**3 - & + 6._default*zeta3 + end if + end subroutine photbar_asym_p + +@ %def photbar_asym +@ +<>= + public :: recbar_singlet +<>= + module subroutine recbar_singlet (x, jll_nll, nlep, ln0, order, running) + real(default), intent(in) :: x + real(default), dimension(6), intent(out) :: jll_nll + real(default), intent(in) :: ln0 + integer, intent(in) :: nlep + logical, dimension(6), intent(in) :: order + logical, intent(in) :: running + end subroutine recbar_singlet +<>= + module subroutine recbar_singlet (x, jll_nll, nlep, ln0, order, running) + real(default), intent(in) :: x + real(default), dimension(6), intent(out) :: jll_nll + real(default), intent(in) :: ln0 + integer, intent(in) :: nlep + logical, dimension(6), intent(in) :: order + logical, intent(in) :: running + real(default) :: c_b0, c_b1ob0 + jll_nll = 0._default + if (running) then + c_b0 = - coeffqed_b0 (0, nlep) + c_b1ob0 = coeffqed_b1 (0, nlep) / coeffqed_b0 (0, nlep) + else + c_b0 = zero + c_b1ob0 = zero + end if + if (order(1)) then + jll_nll(1) = -two + two/(one-x) + end if + if (order(2)) then + jll_nll(2) = -two + 6._default/(one-x) - & + 8._default*log(1-x) + (8._default*log(1-x))/(one-x) + end if + if (order(3)) then + jll_nll(3) = 4.5_default + four*Pi2 + (13.5_default - & + four*Pi2)/(one-x) - 12._default*log(1-x) + & + (36._default*log(1-x))/(one-x) - 24._default*log(1-x)**2 + & + (24._default*log(1-x)**2)/(one-x) + end if + if (order(4)) then + jll_nll(4) = two - two*ln0 + (-two+two*ln0)/(one-x) + & + four*log(1-x) - (four*log(1-x))/(one-x) + end if + if (order(5)) then + jll_nll(5) = (9._default - 12._default*nlep - 18._default*x & + + 32._default*nlep*x - 36._default*c_b0*Pi*x + & + 36._default*c_b1ob0*Pi*x - 12._default*Pi2*x + & + 18._default*ln0*(-two-x+two*c_b0*Pi*x) - & + 18._default*(-two+(-five + four*ln0 + four*c_b0*Pi)*x)*log(1-x) & + + 108._default*x*log(1-x)**2)/(9._default*(-one+x)) + end if + if (order(6)) then + jll_nll(6) = (-9._default*ln0*(36._default + 16._default*c_b0**2*Pi2*x - & + (9._default + 8._default*Pi2)*x - 16._default*c_b0*Pi*(two+x)) + & + two*nlep*(44._default + (22._default + 8._default*Pi2)*x - & + 8._default*c_b0*Pi*(-three + 8._default*x)) + & + two*(16._default*nlep*(-three + 13._default*x) + 36._default*ln0* & + (-6._default + (-three + 8._default*c_b0*Pi)*x) + three*(72._default + & + 48._default*c_b0**2*Pi2*x + (-21._default + 96._default*c_b1ob0*Pi - & + 40._default*Pi2)*x - 24._default*c_b0*Pi*(three + four*x)))*log(1-x) - & + 216._default*(-two + (-three + two*ln0 + four*c_b0*Pi)*x)*log(1-x)**2 + & + 576._default*x*log(1-x)**3 + & + 6._default*(-15._default - 8._default*Pi2 - 12._default*x - & + 10._default*Pi2*x + 24._default*c_b0**2*Pi2*x + & + 24._default*c_b1ob0*Pi*(two+x) + two*c_b0*Pi*(-15._default + & + (21._default - 12._default*c_b1ob0*Pi + 8._default*Pi2)*x) + & + 120._default*x*zeta3)) / (18.*(-one+x)) + end if + end subroutine recbar_singlet + +@ %def recbar_singlet +@ +<>= + public :: recbar_nonsinglet +<>= + module subroutine recbar_nonsinglet (x, jll_nll, nlep, ln0, order, running) + real(default), intent(in) :: x + real(default), dimension(6), intent(out) :: jll_nll + real(default), intent(in) :: ln0 + integer, intent(in) :: nlep + logical, dimension(6), intent(in) :: order + logical, intent(in) :: running + end subroutine recbar_nonsinglet +<>= + module subroutine recbar_nonsinglet (x, jll_nll, nlep, ln0, order, running) + real(default), intent(in) :: x + real(default), dimension(6), intent(out) :: jll_nll + real(default), intent(in) :: ln0 + integer, intent(in) :: nlep + logical, dimension(6), intent(in) :: order + logical, intent(in) :: running + real(default) :: c_b0, c_b1ob0 + jll_nll = 0._default + if (running) then + c_b0 = - coeffqed_b0 (0, nlep) + c_b1ob0 = coeffqed_b1 (0, nlep) / coeffqed_b0 (0, nlep) + else + c_b0 = zero + c_b1ob0 = zero + end if + if (order(1)) then + jll_nll(1) = -two + two/(one - x) + end if + if (order(2)) then + jll_nll(2) = -two + 6._default/(one - x) & + - 8._default*log(1-x) + (8._default*log(1-x))/(one - x) + end if + if (order(3)) then + jll_nll(3) = 4.5_default + 4._default*Pi2 + (13.5_default & + - four*Pi2)/(one - x) - 12._default*log(1-x) + & + (36._default*log(1-x))/(one - x) - 24._default*log(1-x)**2 + & + (24._default*log(1-x)**2)/(one - x) + end if + if (order(4)) then + jll_nll(4) = two - two*ln0 + (-two + two*ln0)/(one-x) + & + four*log(1-x) - (four*log(1-x))/(one-x) + end if + if (order(5)) then + jll_nll(5) = -two - two*ln0+(32._default*nlep)/9._default + & + four*c_b1ob0*Pi - (four*Pi2)/three + one/(one-x) + & + (6._default*ln0)/(one-x) - (20._default*nlep)/(9._default*(one-x)) - & + (four*c_b1ob0*Pi)/(one-x) + (four*Pi2)/(three*(one-x)) + & + 10._default*log(1-x) - 8._default*ln0*log(1-x) - & + (14._default*log(1-x))/(one-x) + (8._default*ln0*log(1-x))/(one-x) + & + 12._default*log(1-x)**2 - (12._default*log(1-x)**2)/(one-x) + & + c_b0*(-four*Pi + four*ln0*Pi + (four*Pi)/(one-x) - & + (four*ln0*Pi)/(one-x) - 8._default*Pi*log(1-x) + & + (8._default*Pi*log(1-x))/(one-x)) + end if + if (order(6)) then + jll_nll(6) = -four + (9._default * ln0)/two + (22._default*nlep)/9._default + & + 8._default*c_b1ob0*Pi - (10._default*Pi2)/three + four*ln0*Pi2 + & + (8._default*nlep*Pi2)/9._default + 9._default/(one-x) + & + (27._default*ln0)/(two*(one-x)) - (22._default*nlep)/(three*(one-x)) - & + (24._default*c_b1ob0*Pi)/(one-x) + (6._default*Pi2)/(one-x) - & + (four*ln0*Pi2)/(one-x) - (8._default*nlep*Pi2)/(9._default*(one-x)) - & + 7._default*log(1-x) - 12._default*ln0*log(1-x) + (208._default* & + nlep*log(1-x))/9._default + 32._default*c_b1ob0*Pi*log(1-x) - & + (40._default*Pi2*log(1-x))/three - (17._default*log(1-x))/(one-x) + & + (36._default*ln0*log(1-x))/(one-x) - (160._default*nlep*log(1-x))/ & + (9._default*(one-x)) - (32._default*c_b1ob0*Pi*log(1-x))/(one-x) + & + (40._default*Pi2*log(1-x))/(three*(one-x)) + 36._default*log(1-x)**2 - & + 24._default*ln0*log(1-x)**2 - (60._default*log(1-x)**2)/(one-x) + & + (24._default*ln0*log(1-x)**2)/(one-x) + 32._default*log(1-x)**3 - & + (32*log(1-x)**3)/(one-x) + c_b0**2*(8._default*Pi2 - & + 8._default*ln0*Pi2 - (8._default*Pi2)/(one-x) + & + (8._default*ln0*Pi2)/(one-x) + 16._default*Pi2*log(1-x) - & + (16._default*Pi2*log(1-x))/(one-x)) + c_b0*(14._default*Pi + & + 8._default*ln0*Pi - (64._default*nlep*Pi)/9._default - & + 8._default*c_b1ob0*Pi2 + (16._default*Pi**3)/three - & + (24._default*ln0*Pi)/(one-x) + (40._default*nlep*Pi)/(9._default*(one-x)) + & + (8._default*c_b1ob0*Pi2)/(one-x) + (-four*Pi - & + (16._default*Pi**3)/three)/(one-x) - 32._default*Pi*log(1-x) + & + 32._default*ln0*Pi*log(1-x) + (56._default*Pi*log(1-x))/(one-x) - & + (32._default*ln0*Pi*log(1-x))/(one-x) - 48._default*Pi*log(1-x)**2 + & + (48*Pi*log(1-x)**2)/(1-x)) + 40._default*zeta3 - (40._default*zeta3)/(one-x) + end if + end subroutine recbar_nonsinglet + +@ %def recbar_nonsinglet +@ +<>= + public :: recbar_photon +<>= + module subroutine recbar_photon (x, jll_nll, nlep, ln0, order, running) + real(default), intent(in) :: x + real(default), dimension(6), intent(out) :: jll_nll + real(default), intent(in) :: ln0 + integer, intent(in) :: nlep + logical, dimension(6), intent(in) :: order + logical, intent(in) :: running + end subroutine recbar_photon +<>= + module subroutine recbar_photon (x, jll_nll, nlep, ln0, order, running) + real(default), intent(in) :: x + real(default), dimension(6), intent(out) :: jll_nll + real(default), intent(in) :: ln0 + integer, intent(in) :: nlep + logical, dimension(6), intent(in) :: order + logical, intent(in) :: running + real(default) :: c_b0, c_b1ob0 + jll_nll = 0._default + if (running) then + c_b0 = - coeffqed_b0 (0, nlep) + c_b1ob0 = coeffqed_b1 (0, nlep) / coeffqed_b0 (0, nlep) + else + c_b0 = zero + c_b1ob0 = zero + end if + if (order(1)) then + jll_nll(1) = one + end if + if (order(2)) then + jll_nll(2) = 1.5_default - (two*nlep)/three + two*log(1-x) + end if + if (order(3)) then + jll_nll(3) = 2.25_default - nlep + (four*nlep**2)/9._default - & + (two*Pi2)/three + (6._default - (four*nlep)/three)*log(1-x) + & + four*log(1-x)**2 + end if + if (order(4)) then + jll_nll(4) = -one + ln0 + end if + if (order(5)) then + jll_nll(5) = -four + (three*ln0)/two - (two*(13._default + & + three*ln0)*nlep)/9._default - two*c_b1ob0*Pi - & + two*c_b0*(-one+ln0)*Pi + (-7._default + two*ln0 - & + (four*nlep)/three)*log(1-x) - three*log(1-x)**2 + end if + if (order(6)) then + jll_nll(6) = -5.625_default - (23._default*nlep)/6._default + & + (52._default*nlep**2)/27._default + four*c_b0*Pi - & + 6._default*c_b1ob0*Pi + (40._default*c_b0*nlep*Pi)/9._default + & + (8._default*c_b1ob0*nlep*Pi)/three + (11._default*Pi2)/6._default - & + four*c_b0**2*Pi2 + four*c_b0*c_b1ob0*Pi2 + (two*nlep*Pi2)/9._default + & + ln0*(2.25_default + (four*nlep**2)/9._default - 6._default*c_b0*PI - & + (two*Pi2)/three + four*c_b0**2*Pi2 + nlep*(-one + & + (8._default*c_b0*Pi)/three)) + (-18.5_default + & + (8._default*nlep**2)/9._default + 18._default*c_b0*Pi - & + 8._default*c_b1ob0*Pi + two*Pi2 + ln0*(6._default - (four*nlep)/three - & + 8._default*c_b0*Pi) + (four*nlep*(-five + two*c_b0*Pi))/three)*log(1-x) + & + (-18.5_default + four*ln0 - (two*nlep)/three + 10._default*c_b0*Pi) * & + log(1-x)**2 - 6._default*log(1-x)**3 - 6._default*zeta3 + end if + end subroutine recbar_photon + +@ %def recbar_photon +@ +<>= + public :: rechat_singlet +<>= + module subroutine rechat_singlet (x, jll_nll, nlep, ln0, order, running) + real(default), intent(in) :: x + real(default), dimension(6), intent(out) :: jll_nll + real(default), intent(in) :: ln0 + integer, intent(in) :: nlep + logical, dimension(6), intent(in) :: order + logical, intent(in) :: running + end subroutine rechat_singlet +<>= + module subroutine rechat_singlet (x, jll_nll, nlep, ln0, order, running) + real(default), intent(in) :: x + real(default), dimension(6), intent(out) :: jll_nll + real(default), intent(in) :: ln0 + integer, intent(in) :: nlep + logical, dimension(6), intent(in) :: order + logical, intent(in) :: running + real(default) :: c_b0, c_b1ob0 + real(default) :: j6_1, j6_2, j6_3 + jll_nll = 0._default + if (running) then + c_b0 = - coeffqed_b0 (0, nlep) + c_b1ob0 = coeffqed_b1 (0, nlep) / coeffqed_b0 (0, nlep) + else + c_b0 = zero + c_b1ob0 = zero + end if + if (order(1)) then + jll_nll(1) = 1-x + end if + if (order(2)) then + jll_nll(2) = -three-x - (two*nlep*(-one+x)*(four+x*(7+4*x)))/(three*x) - & + four*(-one+x)*log(1-x) + ((one-four*nlep+(three+four*nlep)*x**2)*log(x))/(-one+x) + end if + if (order(3)) then + jll_nll(3) = -(-64*nlep**2 - 513*x -552*nlep*x + 16*nlep**2*x - 36*Pi2*x + & + 96*nlep*Pi2*x + 378*x**2 + 1104*nlep*x**2 + 96*nlep**2*x**2 + 144*Pi2*x**2 + & + 135*x**3 - 552*nlep*x**3 + 16*nlep**2*x**3 - 108*Pi2*x**3 -96*nlep*Pi2*x**3 - & + 64*nlep**2*x**4 + 432*(-1+x)**2*x*log(1-x)**2 -54*x*log(x) - & + 96*nlep**2*x*log(x) - 432*x**2*log(x) + 288*nlep*x**2*log(x) - & + 162*x**3*log(x) +96*nlep*x**3*log(x) + 96*nlep**2*x**3*log(x) - & + 384*nlep*x**4*log(x) + 18*x*log(x)**2 - 144*nlep*x*log(x)**2 + & + 126*x**3*log(x)**2 + 144*nlep*x**3*log(x)**2 + 24*log(1-x)*((-1+x) * & + (9*x*(3+x) + 4*nlep*(-4-3*x+3*x**2+4*x**3)) - 18*(x+x**3)*log(x)) + & + 72*(3+8*nlep)*x*(-1+x**2)*polylog(2,x)) / (36._default*(-1+x)*x) + end if + if (order(4)) then + jll_nll(4) = -one + ln0*(1-x) + x - 2*(1-x)*log(1-x) + end if + if (order(5)) then + jll_nll(5) = -(-72*nlep + 48*ln0*nlep+9*x - 54*ln0*x - 176*nlep*x + 36*ln0*nlep*x + & + 36*c_b0*Pi*x - 36*c_b1ob0*Pi*x - 36*c_b0*ln0*Pi*x + 42*Pi2*x + 9*x**2 - & + 18*ln0*x**2 + 368*nlep*x**2 -84*ln0*nlep*x**2 - 36*c_b0*Pi*x**2 + & + 36*c_b1ob0*Pi*x**2 + 36*c_b0*ln0*Pi*x**2 - 42*Pi2*x**2 - 9*x**3 + 54*ln0*x**3 + & + 104*nlep*x**3 - 84*ln0*nlep*x**3 - 36*c_b0*Pi*x**3 + 36*c_b1ob0*Pi*x**3 + & + 36*c_b0*ln0*Pi*x**3 - 18*Pi2*x**3 - 9*x**4 + 18*ln0*x**4 - 296*nlep*x**4 + & + 36*ln0*nlep*x**4 + 36*c_b0*Pi*x**4 - 36*c_b1ob0*Pi*x**4 - 36*c_b0*ln0*Pi*x**4 + & + 18*Pi2*x**4 + 72*nlep*x**5 + 48*ln0*nlep*x**5 + 18*x*log(1-x) + & + 72*ln0*x*log(1-x) + 72*c_b0*Pi*x*log(1-x) + 54*x**2*log(1-x) - & + 72*ln0*x**2*log(1-x) - 72*c_b0*Pi*x**2*log(1-x) - 18*x**3*log(1-x) - & + 72*ln0*x**3*log(1-x) - 72*c_b0*Pi*x**3*log(1-x) - 54*x**4*log(1-x) + & + 72*ln0*x**4*log(1-x) + 72*c_b0*Pi*x**4*log(1-x) - 108*x*log(1-x)**2 + & + 108*x**2*log(1-x)**2 + 108*x**3*log(1-x)**2 - 108*x**4*log(1-x)**2 - & + 96*nlep*log(x) - 18*ln0*x*log(x) - 192*nlep*x*log(x) + 72*ln0*nlep*x*log(x) - & + 18*ln0*x**2*log(x) + 120*nlep*x**2*log(x) + 72*ln0*nlep*x**2*log(x) + & + 18*x**3*log(x) - 54*ln0*x**3*log(x) + 264*nlep*x**3*log(x) - & + 72*ln0*nlep*x**3*log(x) + 18*x**4*log(x) - 54*ln0*x**4*log(x) - & + 48*nlep*x**4*log(x) - 72*ln0*nlep*x**4*log(x) - 96*nlep*x**5*log(x) + & + 72*x**3*log(1-x)*log(x) + 72*x**4*log(1-x)*log(x) + 9*x*log(x)**2 - & + 108*nlep*x*log(x)**2 - 27*x**2*log(x)**2 - 108*nlep*x**2*log(x)**2 + & + 27*x**3*log(x)**2 + 108*nlep*x**3*log(x)**2 - 9*x**4*log(x)**2 + & + 108*nlep*x**4*log(x)**2 + 144*x*log(x)*log(1+x) - 144*x**2*log(x)*log(1+x) - & + 72*x**3*log(x)*log(1+x) + 72*x**4*log(x)*log(1+x) - 108*x*log(1+x)**2 + & + 108*x**2*log(1+x)**2 + 36*(-one+x)*x*(1+x)**2*polylog(2,1-x) + & + 72*x*(2-2*x-x**2+x**3)*polylog(2,-x) - 216*x*polylog(2,1/(1+x)) + & + 216*x**2*polylog(2,1/(1+x))) / (18.*x*(-one+x**2)) + end if + if (order(6)) then + j6_1 = -1152*nlep + 32*nlep**2 + 192*ln0*nlep**2 + 1152*c_b1ob0*nlep*Pi + 96*nlep*Pi2 - & + 1350*x +1539*ln0*x - 3660*nlep*x + 1656*ln0*nlep*x + 720*nlep**2*x + 144*ln0*nlep**2*x - & + 1296*c_b1ob0*Pi*x + 864*c_b1ob0*nlep*Pi*x + 72*Pi2*x + 216*ln0*Pi2*x + 120*nlep*Pi2*x + & + 486*x**2 + 405*ln0*x**2 + 5004*nlep*x**2 - 1656*ln0*nlep*x**2 - 176*nlep**2*x**2 - & + 336*ln0*nlep**2*x**2 - 432*c_b1ob0*Pi*x**2 - 2016*c_b1ob0*nlep*Pi*x**2 + 108*Pi2*x**2 - & + 216*ln0*Pi2*x**2 - 216*nlep*Pi2*x**2 + 1350*x**3 - 1539*ln0*x**3 + 4092*nlep*x**3 - & + 1656*ln0*nlep*x**3 - 1328*nlep**2*x**3 - 336*ln0*nlep**2*x**3 + 1296*c_b1ob0*Pi*x**3 - & + 2016*c_b1ob0*nlep*Pi*x**3 - 504*Pi2*x**3 - 216*ln0*Pi2*x**3 - 216*nlep*Pi2*x**3 - & + 486*x**4 - 405*ln0*x**4 - 3852*nlep*x**4 + 1656*ln0*nlep*x**4 + 144*nlep**2*x**4 + & + 144*ln0*nlep**2*x**4 + 432*c_b1ob0*Pi*x**4 + 864*c_b1ob0*nlep*Pi*x**4 + & + 324*Pi2*x**4 + 216*ln0*Pi2*x**4 + 120*nlep*Pi2*x**4 - 432*nlep*x**5 + & + 608*nlep**2*x**5 + 192*ln0*nlep**2*x**5 + 1152*c_b1ob0*nlep*Pi*x**5 + & + 96*nlep*Pi2*x**5 + 288*Pi2*x*(-1+2*x+x**3)*log(2._default) - & + 216*(-1+x)*(1+x)*(3+x*(7+9*x))*log(2._default)**2 - & + 144*x*(-11+x*(16+x+4*x**2))*log(2._default)**3 - & + 432*c_b0**2*Pi2*(-1+x)**2*x*(1+x)*(-1+ln0-2*log(1-x)) + & + 1728*c_b1ob0*Pi*(-1+x)**2*x*(1+x)*log(1-x) + 6*(16*nlep**2*(-3+x)*x*(1+x)*(-1+3*x) + & + 4*nlep*(8+12*ln0*(-4+x*(-3+7*x*(1+x))) + x*(181+x*(-237+x*(-117+229*x)))) - & + 3*(-1+x)*x*(36*ln0*(1+x)*(3+x)+Pi2*(-56-4*x+44*x**2) + 3*(-37+(-36+x)*x - & + 40*log(2._default)**2)))*log(1-x) + j6_2 = 1512*(-1+x)*x*(1+x)*log(1-x)**2 + 1296*ln0*(-1+x)*x*(1+x)*log(1-x)**2 + & + 1080*(-1+x)*x**2*(1+x)*log(1-x)**2 - 1296*ln0*(-1+x)*x**2*(1+x)*log(1-x)**2 + & + 144*nlep*(-1+x)**2*(1+x)*(4+7*x+4*x**2)*log(1-x)**2 + & + 1728*(-1+x)**2*x*(1+x)*log(1-x)**3 + & + 96*nlep*(4*nlep-9*ln0*x**4+4*(-4-3*ln0+nlep)*x**5)*(log(1-x)-log(x)) - & + 432*c_b1ob0*Pi*x*(1+x)*(1-4*nlep+(3+4*nlep)*x**2)*log(x) - & + 6*(3*ln0*x*(16*nlep**2*(-1+x)*(1+x)**2 + 16*nlep*x*(3+4*x) - 9*(1+x)*(1+x*(8+3*x))) - & + 216*log(2._default) + 2*x*(8*nlep**2*(1+x)*(-7+x*(-13+16*x)) + & + 3*Pi2*(-13+x*(9+(5-9*x)*x)) + 2*nlep*(238 + 18*Pi2*(-1+x)*(1+x)*(2+x) + & + x*(-83+x*(-152+105*x))) + 144*x*log(2._default) + & + 9*(1+x)*(3-x**2+8*(-1+x)*log(2._default) + 4*(-1+x)**2*log(2._default)**2)))*log(x) + & + 216*x*log(1-x)*log(x) - 576*nlep**2*(-1+x)*x*(1+x)**2*log(1-x)*log(x) - & + 216*x**2*(7+10*x)*log(1-x)*log(x) + 648*ln0*x*(1+x)*(1+3*x**2)*log(1-x)*log(x) + & + 144*nlep*(1+x)*(8+x*(15+8*x**3-9*x*(2+x)+12*ln0*(-1+x**2)))*log(1-x)*log(x) - & + 216*(1+x)*(x-4*nlep*x+(11+4*nlep)*x**3)*log(1-x)**2*log(x) + 648*log(x)**2 + & + 432*x*log(x)**2 - 504*nlep*x*(1+x)*log(x)**2 - 1440*nlep*x**4*(1+x)*log(x)**2 + & + 288*nlep**2*(-1+x)*x*(1+x)**2*log(x)**2 + 72*nlep*x**2*(1+x)*(15+8*x)*log(x)**2 - & + 54*ln0*x*(1+x)*(1-8*nlep+(7+8*nlep)*x**2)*log(x)**2 + & + 108*x**2*(-13+x*(-8+7*x))*log(x)**2 - 216*(-1+x)*x*(-5-x*(5+2*x) + & + 2*nlep*(-1+x+2*x**2))*log(1-x)*log(x)**2 + & + 36*x*(-1+x**2)*(-1+5*x+12*nlep*(2+x))*log(x)**3 + 72*x*(Pi2*(-1+x)*(1+x**2) + & + (-x**3+2*(-1+x)*(4+x**2)*log(2._default))*log(64._default))*log(1+x) + & + 1728*(-1+x)*x*log(1-x)*log(x/four)*log(1+x) - 1296*(-1+x)*x*log(x)*log(1+x) - & + 1728*(-1+x)*x**2*log(x)*log(1+x) + 432*x*(1+x)*(2+x*(-3+2*x))*log(x)**2*log(1+x) + & + 432*(-3+2*x*(-1+x*(2+x))+ 2*(-1+x)*x**3*log(2._default) - & + 2*(-1+x)*x*log(2-2*x))*log(2*x)*log(1+x) - 1296*(-1+x)*log(1+x)**2 - & + 2484*(-1+x)*x*log(1+x)**2 + 108*(-1+x)*x**2*(29+14*x)*log(1+x)**2 - & + 1728*x**4*log(2._default)*log(1+x)**2 + 432*x*(-13+15*x)*log(x)*log(1+x)**2 + & + 864*x**3*log(4*x)*log(1+x)**2 - 432*x**4*log(x)*(log((1-x)/2.)+log(1+x)) + & + 288*(-1+x)*x*log(1+x)**2*(3*(log(4-4*x)+log(x)) + (-16+x**2)*log(1+x)) + & + 864*(-1+x)*x*(-((-1+x**2)*log(1-x)) + x**2*log(1+x) -log(32*(1+x)))*polylog(2,(1-x)/2.) + j6_3 = 648*x*(1+x)*polylog(2,1-x) + 648*ln0*x*(1+x)*(-1+x**2)*polylog(2,1-x) - & + 576*nlep**2*x*(1+x)*(-1+x**2)*polylog(2,1-x) + 288*nlep*(-1+x)*(1+x)*(-2 + & + 6*ln0*x*(1+x)+(-3+x)*x*(3+2*x))*polylog(2,1-x) - 432*(-1+x)*x*(1+x)*(4*(2 + & + nlep+x+nlep*x)*log(1-x)+(-1+2*nlep*(-2+x)-x)*log(x)+2*(-1+x)*log(1+x))*polylog(2,1-x) - & + 432*(-1+x**2)*(3+x*(2+x*(-1+log(4._default))-log(4._default)) - & + 2*(-1+x)*x*log(1-x))*polylog(2,(-1+x)/(2.*x)) -1296*(-1+x)*polylog(2,-x) - & + 4320*(-1+x)*x*polylog(2,-x) + 216*(-1+x)*x**2*(-1+15*x)*polylog(2,-x) + & + 864*x*((-1+x)*log(1-x) + (1+x**3)*log(x) + (-5+6*x+x**2)*log(1+x))*polylog(2,-x) + & + 1296*(-1+x)*x*polylog(2,1/(1+x)) + 864*(-1+x)*x**2*polylog(2,1/(1+x)) - & + 1728*(-1+x)*x**3*polylog(2,1/(1+x)) - 2592*(-1+x)*x*log(1-x)*polylog(2,1/(1+x)) - & + 864*x*(-4+5*x+x**3)*log(1+x)*polylog(2,1/(1+x)) + 12*c_b0*Pi*(-224*nlep+96*ln0*nlep + & + 90*x-108*ln0*x - 212*nlep*x+72*ln0*nlep*x - 36*c_b1ob0*Pi*x+54*Pi2*x - 36*ln0*x**2 + & + 556*nlep*x**2-168*ln0*nlep*x**2 + 36*c_b1ob0*Pi*x**2 - 54*Pi2*x**2 - 90*x**3 + & + 108*ln0*x**3+292*nlep*x**3 - 168*ln0*nlep*x**3 + 36*c_b1ob0*Pi*x**3 - 30*Pi2*x**3 + & + 36*ln0*x**4 - 332*nlep*x**4 + 72*ln0*nlep*x**4 - 36*c_b1ob0*Pi*x**4 + & + 30*Pi2*x**4 - 80*nlep*x**5 + 96*ln0*nlep*x**5 + 36*x*(-1+x**2)*(4*ln0*(-1+x) - & + 3*(1+x))*log(1-x) + 216*(-1+x)*x*(1+x)*log(1-x)**2 - 216*(-1+x)*x**2*(1+x)*log(1-x)**2 - & + 6*(1+x)*(3*x*(-1-2*x*(1+x)+ln0*(2+6*x**2)) + 4*nlep*(8+x*(9+4*(-3+x)*x*(1+x) + & + 6*ln0*(-1+x**2))))*log(x) + 36*x*(1+x)*(1+5*x**2)*log(1-x)*log(x) - & + 9*(-1+x)**3*x*log(x)**2 + 180*nlep*x*(1+x)*(-1+x**2)*log(x)**2 + & + 72*(-1+x)*x*(-2+x**2)*log(x)*log(1+x) + 108*(-1+x)*x*log(1+x)**2 + & + 72*x*(1+x)*(-1+x**2)*polylog(2,1-x) + 72*(-1+x)*x*(-2+x**2)*polylog(2,-x) + & + 216*(-1+x)*x*polylog(2,1/(1+x))) + & + 216*(-1+x**2)*(-6+x*(-8+5*x)+10*(-1+x)*x*log(1+x))*polylog(2,x/(1+x)) + & + 432*(-1+x)*(1+x)*(-3+x*(-2+x+log(4._default)-x*log(4._default))+2*(-1+x)*x*log(1+x)) * & + polylog(2,-1+2/(1+x)) + 864*(-1+x)**2*x*(1+x)*polylog(3,(1-x)/2.) + & + 432*x*(-1+x**2)*(8+3*x+4*nlep*(1+x))*polylog(3,1-x) - & + 864*(-1+x)**2*x*(1+x)*polylog(3,(-1+x)/(2.*x)) - & + 432*x*(6*nlep+x)*(-1+x**2)*polylog(3,(-1+x)/x) + & + 432*x*(1+x)*(7+x*(-16+7*x))*polylog(3,-x) + & + 216*x*(9+20*nlep+3*x+8*nlep*x)*(-1+x**2)*polylog(3,x) + & + 864*x*(1+x)*(3+x*(-4+3*x))*polylog(3,1/(1+x)) + & + 3024*(-1+x)**2*x*(1+x)*polylog(3,x/(1+x)) - & + 864*(-1+x)**2*x*(1+x)*polylog(3,(2*x)/(1+x)) + & + 864*(-1+x)*x*(4+x**2)*polylog(3,(1+x)/2.) - & + 54*x*(-107+16*nlep*(-1+x)*(1+x)*(5+2*x)+x*(99+x*(67+21*x)))*zeta3 + jll_nll(6) = (j6_1 + j6_2 + j6_3) / (108._default*x*(-one+x**2)) + end if + end subroutine rechat_singlet + +@ %def rechat_singlet +@ +<>= + public :: rechat_nonsinglet +<>= + module subroutine rechat_nonsinglet (x, jll_nll, nlep, ln0, order, running) + real(default), intent(in) :: x + real(default), dimension(6), intent(out) :: jll_nll + real(default), intent(in) :: ln0 + integer, intent(in) :: nlep + logical, dimension(6), intent(in) :: order + logical, intent(in) :: running + end subroutine rechat_nonsinglet +<>= + module subroutine rechat_nonsinglet (x, jll_nll, nlep, ln0, order, running) + real(default), intent(in) :: x + real(default), dimension(6), intent(out) :: jll_nll + real(default), intent(in) :: ln0 + integer, intent(in) :: nlep + logical, dimension(6), intent(in) :: order + logical, intent(in) :: running + real(default) :: c_b0, c_b1ob0 + real(default) :: j6_1, j6_2, j6_3 + jll_nll = 0._default + if (running) then + c_b0 = - coeffqed_b0 (0, nlep) + c_b1ob0 = coeffqed_b1 (0, nlep) / coeffqed_b0 (0, nlep) + else + c_b0 = zero + c_b1ob0 = zero + end if + if (order(1)) then + jll_nll(1) = 1-x + end if + if (order(2)) then + jll_nll(2) = ((1 - x)*(3 + x) - 4*(-1 + x)**2*log(1-x) + log(x) + 3*x**2*log(x)) / (-1 + x) + end if + if (order(3)) then + jll_nll(3) = ((-1 + x)*(4*Pi2*(-1 + 3*x) - 3*(19 + 5*x)) - 48*(-1 + x)**2*log(1-x)**2 - & + 2*log(x)*(-3 - 9*x**2 + log(x) + 7*x**2*log(x)) + 24*log(1-x)*(3 - x**2 + & + 2*(1 + x**2)*log(x)) - 48*x*(log(2 - 2*x) - log(2*x)) - 24*(-1 + x**2)*polylog(2,x)) / & + (four*(-1 + x)) + end if + if (order(4)) then + jll_nll(4) = (1-x)*(-1+ln0-2*log(1-x)) + end if + if (order(5)) then + jll_nll(5) = (135 + 54*ln0 + 68*nlep - 36*c_b0*Pi + 36*c_b1ob0*Pi + 36*c_b0*ln0*Pi + & + 18*Pi2 - 153*x + 18*ln0*x - 44*nlep*x + 36*c_b0*Pi*x - 36*c_b1ob0*Pi*x - & + 36*c_b0*ln0*Pi*x - 18*Pi2*x - 135*x**2 - 54*ln0*x**2 - 68*nlep*x**2 + 36*c_b0*Pi*x**2 - & + 36*c_b1ob0*Pi*x**2 - 36*c_b0*ln0*Pi*x**2 + 6*Pi2*x**2 + 153*x**3 - 18*ln0*x**3 + & + 44*nlep*x**3 - 36*c_b0*Pi*x**3 + 36*c_b1ob0*Pi*x**3 + 36*c_b0*ln0*Pi*x**3 - & + 6*Pi2*x**3 - 18*log(1-x) - 72*ln0*log(1-x) - 72*c_b0*Pi*log(1-x) - 54*x*log(1-x) + & + 72*ln0*x*log(1-x) + 72*c_b0*Pi*x*log(1-x) + 18*x**2*log(1-x) + 72*ln0*x**2*log(1-x) + & + 72*c_b0*Pi*x**2*log(1-x) + 54*x**3*log(1-x) - 72*ln0*x**3*log(1-x) - & + 72*c_b0*Pi*x**3*log(1-x) + 108*log(1-x)**2 - 108*x*log(1-x)**2 - 108*x**2*log(1-x)**2 + & + 108*x**3*log(1-x)**2 + 72*log(x) + 18*ln0*log(x) + 12*nlep*log(x) + 72*x*log(x) + & + 18*ln0*x*log(x) + 12*nlep*x*log(x) - 90*x**2*log(x) + 54*ln0*x**2*log(x) + & + 12*nlep*x**2*log(x) - 90*x**3*log(x) + 54*ln0*x**3*log(x) + 12*nlep*x**3*log(x) - & + 72*x**2*log(1-x)*log(x) - 72*x**3*log(1-x)*log(x) + 27*log(x)**2 - 9*x*log(x)**2 + & + 9*x**2*log(x)**2 - 27*x**3*log(x)**2 + 144*log(x)*log(1+x) - 144*x*log(x)*log(1+x) - & + 72*x**2*log(x)*log(1+x) + 72*x**3*log(x)*log(1+x) - 108*log(1+x)**2 + 108*x*log(1+x)**2 - & + 36*(-1+x)*(1+x)**2*polylog(2,1-x) + 72*(2-2*x-x**2+x**3)*polylog(2,-x) - & + 216*polylog(2,1/(1+x)) + 216*x*polylog(2,1/(1+x))) / (18._default*(-1+x**2)) + end if + if (order(6)) then + j6_1 = 24*Pi2*(-1+x)*x + 4*nlep*(63+4*Pi2*(-1+x)-19*x)*(-1+x)*x*(1+x) + & + 144*c_b1ob0*Pi*(-1+x)*x*(1+x)*(3+x) - 12*Pi2*(-1+x)*x**2*(3+17*x) - & + 18*(-1+x)*x*(1+x)*(-73+57*x) + 9*ln0*(-1+x)*x*(1+x)*(8*Pi2*(-1+x)-3*(19+5*x)) + & + 24*log(2._default)*(-4*Pi2*x*(-1+2*x+x**3)+2*x*(-11+x*(16+x+4*x**2))*log(2._default)**2 + & + (-1+x)*(1+x)*(3+x*(7+9*x))*log(8._default)) - & + 144*c_b0**2*Pi2*(-1+x)**2*x*(1+x)*(-1+ln0-2*log(1-x)) + & + 576*c_b1ob0*Pi*(-1+x)**2*x*(1+x)*log(1-x) - & + 2*(-1+x)*x*(108*ln0*(1+x)*(3+x)+32*nlep*(11+(3-8*x)*x)+3*(81-27*x*(4+7*x) + & + 4*Pi2*(-6+x+9*x**2)+120*log(2._default)**2))*log(1-x) + & + 504*(-1+x)*x*(1+x)*log(1-x)**2 - 432*ln0*(-1+x)**2*x*(1+x)*log(1-x)**2 + & + 360*(-1+x)*x**2*(1+x)*log(1-x)**2 + 576*(-1+x)**2*x*(1+x)*log(1-x)**3 - & + 540*x*log(x) + 54*ln0*x*log(x) - 152*nlep*x*log(x) - 144*c_b1ob0*Pi*x*log(x) - & + 84*Pi2*x*log(x) + 612*x**2*log(x) + 486*ln0*x**2*log(x) + 136*nlep*x**2*log(x) - & + 144*c_b1ob0*Pi*x**2*log(x) + 132*Pi2*x**2*log(x) + 468*x**3*log(x) + & + 594*ln0*x**3*log(x)-24*nlep*x**3*log(x) - 432*c_b1ob0*Pi*x**3*log(x) + & + 84*Pi2*x**3*log(x) - 684*x**4*log(x)+162*ln0*x**4*log(x) - & + 312*nlep*x**4*log(x) - 432*c_b1ob0*Pi*x**4*log(x) - 36*Pi2*x**4*log(x) - & + 432*log(2._default)*log(x) - 288*x*log(2._default)*log(x) + & + 576*x**2*log(2._default)*log(x)+288*x**3*log(2._default)*log(x) - & + 144*x**4*log(2._default)*log(x) + j6_2 = 144*x*log(2._default)**2*log(x) - 144*x**2*log(2._default)**2*log(x) - & + 144*x**3*log(2._default)**2*log(x) + 144*x**4*log(2._default)**2*log(x) + & + 648*x*(1+x)*log(1-x)*log(x) + 216*ln0*x*(1+x)*log(1-x)*log(x) + & + 96*nlep*x*(1+x)*log(1-x)*log(x) - 576*x**2*(1+x)*log(1-x)*log(x) - & + 720*x**3*(1+x)*log(1-x)*log(x) + 648*ln0*x**3*(1+x)*log(1-x)*log(x) + & + 96*nlep*x**3*(1+x)*log(1-x)*log(x) - 72*x*(1+x)*(1+11*x**2)*log(1-x)**2*log(x) - & + 216*log(x)**2-288*x*log(x)**2 - 18*ln0*x*log(x)**2-24*nlep*x*log(x)**2 + & + 108*x**2*log(x)**2 - 18*ln0*x**2*log(x)**2-24*nlep*x**2*log(x)**2 + & + 288*x**3*log(x)**2 - 126*ln0*x**3*log(x)**2 - 72*nlep*x**3*log(x)**2 - & + 36*x**4*log(x)**2 - 126*ln0*x**4*log(x)**2 - 72*nlep*x**4*log(x)**2 + & + 72*(-1+x)*x*(1+x*(5+2*x))*log(1-x)*log(x)**2 - 36*x*log(x)**3 - & + 12*x**2*log(x)**3+36*x**3*log(x)**3 + 12*x**4*log(x)**3 - & + 576*(-1+x)*x*log(1-x)*log(x/four)*log(1+x) + 432*(-1+x)*x*log(x)*log(1+x) + & + 576*(-1+x)*x**2*log(x)*log(1+x) - 144*x*(1+x)*(2+x*(-3+2*x))*log(x)**2*log(1+x) - & + 24*(-1+x)*(Pi2*(x+x**3)+12*x*(4+x**2)*log(2._default)**2 + & + 6*(3+x*(5+x+x**2*(-1+log(4._default)))-2*x*log(2-2*x))*log(2*x))*log(1+x) + & + 432*(-1+x)*log(1+x)**2+828*(-1+x)*x*log(1+x)**2 - 36*(-1+x)*x**2*(29+14*x)*log(1+x)**2 + j6_3 = 576*x**4*log(2._default)*log(1+x)**2 - 144*x*(-13+15*x)*log(x)*log(1+x)**2 - & + 288*(-1+x)*x*(log(4-4*x)+log(x))*log(1+x)**2 - 288*x**3*log(4*x)*log(1+x)**2 - & + 96*(-4+x)*(-1+x)*x*(4+x)*log(1+x)**3 + & + 288*(-1+x)*x*(log(32._default)+(-1+x**2)*log(1-x)-(-1+x**2)*log(1+x))*polylog(2,(1-x)/two) + & + 792*x*(1+x)*polylog(2,1-x) - 216*ln0*x*(1+x)*polylog(2,1-x) - & + 576*x**3*(1+x)*polylog(2,1-x) + 216*ln0*x**3*(1+x)*polylog(2,1-x) + & + 72*x*(1+x)*log((-1+x)**8)*polylog(2,1-x) - 144*x*(1+x)*log(x)*polylog(2,1-x) + & + 288*x*(1+x)*log(1+x)*polylog(2,1-x) + & + 144*x**2*(1+x)*((4-8*x)*log(1-x)+x*log(x)+2*(-2+x)*log(1+x))*polylog(2,1-x) + & + 144*(-1+x**2)*(3+x*(2+x*(-1+log(4._default))-log(4._default)) - & + 2*(-1+x)*x*log(1-x))*polylog(2,(-1+x)/(two*x)) + 432*(-1+x)*polylog(2,-x) + & + 1440*(-1+x)*x*polylog(2,-x) - 72*(-1+x)*x**2*(-1+15*x)*polylog(2,-x) - & + 288*x*((-1+x)*log(1-x)+(1+x**3)*log(x)+(-5+6*x+x**2)*log(1+x))*polylog(2,-x) - & + 432*(-1+x)*x*polylog(2,1/(1+x)) - 288*(-1+x)*x**2*polylog(2,1/(1+x)) + & + 576*(-1+x)*x**3*polylog(2,1/(1+x)) + 864*(-1+x)*x*log(1-x)*polylog(2,1/(1+x)) + & + 288*x*(-4+5*x+x**3)*log(1+x)*polylog(2,1/(1+x)) + & + 4*c_b0*Pi*x*(-36*c_b1ob0*Pi*(-1+x)*(-1+x**2)-2*(1-x)*(18*ln0*(1+x)*(3+x) - & + 2*nlep*(1+x)*(-17+11*x)+3*(9+Pi2-15*x+3*(-8+Pi2)*x**2))+36*(3-3*(-1+x)*x + & + 4*ln0*(-1+x)**2*(1+x))*log(1-x)-216*(-1+x)**2*(1+x)*log(1-x)**2 - & + 108*x**3*(log(1-x)-log(x))-54*log(x)-36*ln0*log(x) - & + 12*nlep*log(x)-18*x*log(x)-36*ln0*x*log(x)-12*nlep*x*log(x)+144*x**2*log(x) - & + 108*ln0*x**2*log(x)-12*nlep*x**2*log(x)-108*ln0*x**3*log(x)-12*nlep*x**3*log(x) + & + 36*(1+x)*log(1-x)*log(x) + & + 180*x**2*(1+x)*log(1-x)*log(x)-27*log(x)**2+9*x*log(x)**2-9*x**2*log(x)**2 + & + 27*x**3*log(x)**2 - 72*(-1+x)*(-2+x**2)*log(x)*log(1+x)-108*(-1+x)*log(1+x)**2 - & + 72*(1+x)*polylog(2,1-x) + 72*x**2*(1+x)*polylog(2,1-x)-72*(-1+x)*(-2+x**2)*polylog(2,-x) - & + 216*(-1+x)*polylog(2,one/(1+x))) - & + 72*(-1+x**2)*(-6+x*(-8+5*x)+10*(-1+x)*x*log(1+x))*polylog(2,x/(1+x)) + & + 144*(-1+x**2)*(3+x*(2+x*(-1+log(4._default))-log(4._default)) - & + 2*(-1+x)*x*log(1+x))*polylog(2,-one+two/(1+x)) - 288*(-1+x)**2*x*(1+x)*polylog(3,(1-x)/two) + & + 144*(-1+x)*x*(1+x)*(4+7*x)*polylog(3,1-x) + 288*(-1+x)**2*x*(1+x)*polylog(3,(-1+x)/(two*x)) - & + 144*x**2*(-1+x**2)*polylog(3,(-1+x)/x) - 144*x*(1+x)*(7+x*(-16+7*x))*polylog(3,-x) + & + 72*(-1+x)*x*(1+x)*(5+7*x)*polylog(3,x) + 288*x*(-3+x+x**2-3*x**3)*polylog(3,one/(1+x)) - & + 1008*(-1+x)**2*x*(1+x)*polylog(3,x/(1+x)) + 288*(-1+x)**2*x*(1+x)*polylog(3,(2*x)/(1+x)) - & + 288*(-1+x)*x*(4+x**2)*polylog(3,(1+x)/two) + 18*x*(29+x*(59+x*(-69+61*x)))*zeta3 + jll_nll(6) = (j6_1 + j6_2 + j6_3) / (36._default*x*(-1+x**2)) + end if + end subroutine rechat_nonsinglet + +@ %def rechat_nonsinglet +@ +<>= + public :: rechat_photon +<>= + module subroutine rechat_photon (x, jll_nll, nlep, ln0, order, running) + real(default), intent(in) :: x + real(default), dimension(6), intent(out) :: jll_nll + real(default), intent(in) :: ln0 + integer, intent(in) :: nlep + logical, dimension(6), intent(in) :: order + logical, intent(in) :: running + end subroutine rechat_photon +<>= + module subroutine rechat_photon (x, jll_nll, nlep, ln0, order, running) + real(default), intent(in) :: x + real(default), dimension(6), intent(out) :: jll_nll + real(default), intent(in) :: ln0 + integer, intent(in) :: nlep + logical, dimension(6), intent(in) :: order + logical, intent(in) :: running + real(default) :: c_b0, c_b1ob0 + real(default) :: j6_1, j6_2, j6_3 + jll_nll = 0._default + if (running) then + c_b0 = - coeffqed_b0 (0, nlep) + c_b1ob0 = coeffqed_b1 (0, nlep) / coeffqed_b0 (0, nlep) + else + c_b0 = zero + c_b1ob0 = zero + end if + if (order(1)) then + jll_nll(1) = -3 + 2/x + x + end if + if (order(2)) then + jll_nll(2) = -((-1+x)*(4*nlep*(-2+x)+3*x)-12*(2-3*x+x**2)*log(1-x) + 6*(-2+x)*x*log(x)) / & + (6._default*x) + end if + if (order(3)) then + jll_nll(3) = (-99 + 1068*nlep - 48*nlep**2 + 72*Pi2 - (496*nlep)/x + (32*nlep**2)/x + & + 99*x - 636*nlep*x + 16*nlep**2*x - 24*Pi2*x + 64*nlep*x**2 + & + (144*(2-3*x+x**2)*log(1-x)**2)/x - 180*log(x) - 48*nlep*log(x) - (192*nlep*log(x))/x + & + 72*x*log(x) + 240*nlep*x*log(x) - 36*log(x)**2 + 144*nlep*log(x)**2 + 18*x*log(x)**2 - & + 72*nlep*x*log(x)**2 - (24*log(1-x)*((-1+x)*(2*nlep*(-2+x)+3*x) + & + 6*(2-2*x+x**2)*log(x))) / x - (288*polylog(2,x))/x) / 36._default + end if + if (order(4)) then + jll_nll(4) = ((-1+ln0)*(2-3*x+x**2) - 2*(2-2*x+x**2)*log(x)) / x + end if + if (order(5)) then + jll_nll(5) = (45 + 9*ln0 + 108*nlep + 36*ln0*nlep + 108*c_b1ob0*Pi - (56*nlep)/x - & + (24*ln0*nlep)/x - (72*c_b1ob0*Pi)/x - 45*x - 9*ln0*x - 52*nlep*x - 12*ln0*nlep*x - & + 36*c_b1ob0*Pi*x - (54*(2-3*x+x**2)*log(1-x)**2)/x + 36*ln0*log(x) - 48*nlep*log(x) + & + (48*nlep*log(x))/x + 45*x*log(x) - 18*ln0*x*log(x) + 24*nlep*x*log(x) - 18*log(x)**2 + & + 9*x*log(x)**2 + (6*log(1-x)*((-1+x)*(12+8*nlep+6*ln0*(-2+x)-9*x-4*nlep*x) + & + 6*(-2+x)*x*log(x)))/x - (36*c_b0*Pi*((-1+ln0)*(2-3*x+x**2) - 2*(2-2*x+x**2)*log(x))) / x + & + 36*(-2+x)*polylog(2,1-x))/18._default + end if + if (order(6)) then + j6_1 = -2808+2176*nlep + 2976*ln0*nlep - 448*nlep**2 - 192*ln0*nlep**2 - 768*c_b0*nlep*Pi - & + 1152*c_b1ob0*nlep*Pi - 1152*c_b0*ln0*nlep*Pi + 144*Pi2 + 1728*c_b0**2*Pi2 - & + 1728*c_b0*c_b1ob0*Pi2 + 288*ln0*Pi2 - 1728*c_b0**2*ln0*Pi2 - 96*nlep*Pi2 + & + 3645*x+594*ln0*x + 12420*nlep*x - 6408*ln0*nlep*x + 864*nlep**2*x + 288*ln0*nlep**2*x + & + 648*c_b0*Pi*x + 432*c_b1ob0*Pi*x + 432*c_b0*ln0*Pi*x + 1728*c_b0*nlep*Pi*x + & + 1728*c_b1ob0*nlep*Pi*x + 1728*c_b0*ln0*nlep*Pi*x + 324*Pi2*x - 2592*c_b0**2*Pi2*x + & + 2592*c_b0*c_b1ob0*Pi2*x - 432*ln0*Pi2*x + 2592*c_b0**2*ln0*Pi2*x + 144*nlep*Pi2*x + & + 1971*x**2 - 594*ln0*x**2 - 16324*nlep*x**2 + 840*ln0*nlep*x**2 + 32*nlep**2*x**2 + & + 96*ln0*nlep**2*x**2 - 648*c_b0*Pi*x**2 - 432*c_b1ob0*Pi*x**2 - 432*c_b0*ln0*Pi*x**2 - & + 192*c_b0*nlep*Pi*x**2 + 576*c_b1ob0*nlep*Pi*x**2 + 576*c_b0*ln0*nlep*Pi*x**2 - & + 180*Pi2*x**2-864*c_b0**2*Pi2*x**2 + 864*c_b0*c_b1ob0*Pi2*x**2 - 144*ln0*Pi2*x**2 + & + 864*c_b0**2*ln0*Pi2*x**2 + 48*nlep*Pi2*x**2 - 3645*x**3-594*ln0*x**3 - & + 12868*nlep*x**3+6024*ln0*nlep*x**3 - 864*nlep**2*x**3 - 288*ln0*nlep**2*x**3 - & + 648*c_b0*Pi*x**3 - 432*c_b1ob0*Pi*x**3 - 432*c_b0*ln0*Pi*x**3 - 1728*c_b0*nlep*Pi*x**3 - & + 1728*c_b1ob0*nlep*Pi*x**3 - 1728*c_b0*ln0*nlep*Pi*x**3 - 468*Pi2*x**3 + & + 2592*c_b0**2*Pi2*x**3 - 2592*c_b0*c_b1ob0*Pi2*x**3 + 432*ln0*Pi2*x**3 - & + 2592*c_b0**2*ln0*Pi2*x**3 - 144*nlep*Pi2*x**3 + 837*x**4 + 594*ln0*x**4 + 14148*nlep*x**4 - & + 3816*ln0*nlep*x**4 + 416*nlep**2*x**4 + 96*ln0*nlep**2*x**4 + 648*c_b0*Pi*x**4 + & + 432*c_b1ob0*Pi*x**4 + 432*c_b0*ln0*Pi*x**4 + 960*c_b0*nlep*Pi*x**4 + & + 576*c_b1ob0*nlep*Pi*x**4 + 576*c_b0*ln0*nlep*Pi*x**4 + 180*Pi2*x**4 - 864*c_b0**2*Pi2*x**4 + & + 864*c_b0*c_b1ob0*Pi2*x**4 - 144*ln0*Pi2*x**4 + 864*c_b0**2*ln0*Pi2*x**4 + 48*nlep*Pi2*x**4 + & + 448*nlep*x**5 + 384*ln0*nlep*x**5 - 864*Pi2*x*log(2._default) + & + 864*Pi2*x**3*log(2._default) + 2016*x*log(2._default)**3 - 2016*x**3*log(2._default)**3 - & + 384*nlep**2*log(2-2*x) + 432*ln0*x**2*log(2-2*x) + 192*nlep**2*x**2*log(2-2*x) - & + 432*ln0*x**4*log(2-2*x) + 192*nlep**2*x**4*log(2-2*x) + 1080*log(1-x) + 2304*nlep*log(1-x) + & + 576*ln0*nlep*log(1-x) - 864*c_b0*Pi*log(1-x) + 3456*c_b1ob0*Pi*log(1-x) + & + 3456*c_b0*ln0*Pi*log(1-x) - 1152*c_b0*nlep*Pi*log(1-x) - 576*Pi2*log(1-x) - 3564*x*log(1-x) - & + 432*ln0*x*log(1-x) - 3744*nlep*x*log(1-x) - 864*ln0*nlep*x*log(1-x) + & + 576*nlep**2*x*log(1-x) + 1296*c_b0*Pi*x*log(1-x) - 5184*c_b1ob0*Pi*x*log(1-x) - & + 5184*c_b0*ln0*Pi*x*log(1-x) + 1728*c_b0*nlep*Pi*x*log(1-x) + 1008*Pi2*x*log(1-x) + j6_2 = 1404*x**2*log(1-x) - 864*nlep*x**2*log(1-x) - 288*ln0*nlep*x**2*log(1-x) + & + 432*c_b0*Pi*x**2*log(1-x) - 1728*c_b1ob0*Pi*x**2*log(1-x) - 1728*c_b0*ln0*Pi*x**2*log(1-x) + & + 576*c_b0*nlep*Pi*x**2*log(1-x) + 144*Pi2*x**2*log(1-x) + 3564*x**3*log(1-x) + & + 432*ln0*x**3*log(1-x) + 3744*nlep*x**3*log(1-x) + 864*ln0*nlep*x**3*log(1-x) - & + 576*nlep**2*x**3*log(1-x) - 1296*c_b0*Pi*x**3*log(1-x) + 5184*c_b1ob0*Pi*x**3*log(1-x) + & + 5184*c_b0*ln0*Pi*x**3*log(1-x) - 1728*c_b0*nlep*Pi*x**3*log(1-x) - 1008*Pi2*x**3*log(1-x) - & + 2484*x**4*log(1-x) - 1440*nlep*x**4*log(1-x) - 288*ln0*nlep*x**4*log(1-x) + & + 432*c_b0*Pi*x**4*log(1-x) - 1728*c_b1ob0*Pi*x**4*log(1-x) - 1728*c_b0*ln0*Pi*x**4*log(1-x) + & + 576*c_b0*nlep*Pi*x**4*log(1-x) + 432*Pi2*x**4*log(1-x) + 1728*log(1-x)**2 - & + 1728*ln0*log(1-x)**2 + 288*nlep*log(1-x)**2 - 4320*c_b0*Pi*log(1-x)**2 - & + 2700*x*log(1-x)**2 + 2592*ln0*x*log(1-x)**2 - 432*nlep*x*log(1-x)**2 + & + 6480*c_b0*Pi*x*log(1-x)**2 - 756*x**2*log(1-x)**2 + 864*ln0*x**2*log(1-x)**2 - & + 144*nlep*x**2*log(1-x)**2 + 2160*c_b0*Pi*x**2*log(1-x)**2 + 2700*x**3*log(1-x)**2 - & + 2592*ln0*x**3*log(1-x)**2 + 432*nlep*x**3*log(1-x)**2 - 6480*c_b0*Pi*x**3*log(1-x)**2 - & + 972*x**4*log(1-x)**2 + 864*ln0*x**4*log(1-x)**2 - 144*nlep*x**4*log(1-x)**2 + & + 2160*c_b0*Pi*x**4*log(1-x)**2 + 1728*log(1-x)**3 - 3024*x*log(1-x)**3 - & + 432*x**2*log(1-x)**3 + 3024*x**3*log(1-x)**3 - 1296*x**4*log(1-x)**3 - 2880*nlep*log(x) + & + 1152*ln0*nlep*log(x) + 2304*c_b0*nlep*Pi*log(x) + 3456*c_b0**2*Pi2*log(x) - & + 2916*x*log(x) + 1080*ln0*x*log(x) + 18288*nlep*x*log(x) + 288*ln0*nlep*x*log(x) - & + 384*nlep**2*x*log(x) - 864*c_b0*Pi*x*log(x) + 1728*c_b1ob0*Pi*x*log(x) + & + 1728*c_b0*ln0*Pi*x*log(x) - 2304*c_b0*nlep*Pi*x*log(x)+288*Pi2*x*log(x) - & + 3456*c_b0**2*Pi2*x*log(x) - 702*x**2*log(x) + 3960*nlep*x**2*log(x) - & + 2592*ln0*nlep*x**2*log(x) + 648*c_b0*Pi*x**2*log(x) - 864*c_b1ob0*Pi*x**2*log(x) - & + 864*c_b0*ln0*Pi*x**2*log(x) - 1152*c_b0*nlep*Pi*x**2*log(x) - 864*Pi2*x**2*log(x) - & + 1728*c_b0**2*Pi2*x**2*log(x) + 2916*x**3*log(x) - 1080*ln0*x**3*log(x) - & + 17520*nlep*x**3*log(x) - 288*ln0*nlep*x**3*log(x) + 384*nlep**2*x**3*log(x) + & + 864*c_b0*Pi*x**3*log(x) - 1728*c_b1ob0*Pi*x**3*log(x) - 1728*c_b0*ln0*Pi*x**3*log(x) + & + 2304*c_b0*nlep*Pi*x**3*log(x) - 864*Pi2*x**3*log(x) + 3456*c_b0**2*Pi2*x**3*log(x) + & + 702*x**4*log(x) - 1080*nlep*x**4*log(x) + 1440*ln0*nlep*x**4*log(1-x) - & + 648*c_b0*Pi*x**4*log(x) + 864*c_b1ob0*Pi*x**4*log(x) + 864*c_b0*ln0*Pi*x**4*log(x) - & + 1152*c_b0*nlep*Pi*x**4*log(x) + 288*Pi2*x**4*log(x) - 1728*c_b0**2*Pi2*x**4*log(x) - & + 768*nlep*x**5*log(x) - 1296*x*log(1-x)*log(x) - 1728*ln0*x*log(1-x)*log(x) - & + 3456*c_b0*Pi*x*log(1-x)*log(x) - 648*x**2*log(1-x)*log(x) + & + 864*ln0*x**2*log(1-x)*log(x) + 1728*c_b0*Pi*x**2*log(1-x)*log(x) + & + 1296*x**3*log(1-x)*log(x) + 1728*ln0*x**3*log(1-x)*log(x) + j6_3 = 3456*c_b0*Pi*x**3*log(1-x)*log(x) + 648*x**4*log(1-x)*log(x) - & + 864*ln0*x**4*log(1-x)*log(x) - 1728*c_b0*Pi*x**4*log(1-x)*log(x) + & + 3024*x*log(1-x)**2*log(x) - 1512*x**2*log(1-x)**2*log(x) - & + 3024*x**3*log(1-x)**2*log(x) + 1512*x**4*log(1-x)**2*log(x) - 1152*nlep*log(x)**2 - & + 432*x*log(x)**2 + 216*ln0*x*log(x)**2 + 1728*nlep*x*log(x)**2 - & + 864*ln0*nlep*x*log(x)**2 - 432*c_b0*Pi*x*log(x)**2 - 432*x**2*log(x)**2 - & + 108*ln0*x**2*log(x)**2 + 2016*nlep*x**2*log(x)**2 + 432*ln0*nlep*x**2*log(x)**2 + & + 216*c_b0*Pi*x**2*log(x)**2 + 432*x**3*log(x)**2 - 216*ln0*x**3*log(x)**2 - & + 1728*nlep*x**3*log(x)**2 + 864*ln0*nlep*x**3*log(x)**2 + 432*c_b0*Pi*x**3*log(x)**2 + & + 432*x**4*log(x)**2 + 108*ln0*x**4*log(x)**2 - 864*nlep*x**4*log(x)**2 - & + 432*ln0*nlep*x**4*log(x)**2 - 216*c_b0*Pi*x**4*log(x)**2 - 2592*x*log(1-x)*log(x)**2 + & + 3024*x**2*log(1-x)*log(x)**2 + 4320*x**3*log(1-x)*log(x)**2 - & + 1296*x**4*log(1-x)*log(x)**2 - 144*x*log(x)**3 + 1152*nlep*x*log(x)**3 - & + 936*x**2*log(x)**3 - 576*nlep*x**2*log(x)**3 - 432*x**3*log(x)**3 - & + 1152*nlep*x**3*log(x)**3 + 360*x**4*log(x)**3 + 576*nlep*x**4*log(x)**3 + & + 384*nlep**2*log(2*x) - 432*ln0*x**2*log(2*x) - 192*nlep**2*x**2*log(2*x) + & + 432*ln0*x**4*log(2*x) - 192*nlep**2*x**4*log(2*x) + 576*Pi2*log(1+x) + & + 2016*Pi2*x*log(1+x) - 2016*Pi2*x**2*log(1+x) - 576*Pi2*x**3*log(1+x) + & + 2592*log(x)*log(1+x) + 2592*x*log(x)*log(1+x) - 864*x**2*log(x)*log(1+x) - & + 3456*x**3*log(x)*log(1+x) - 864*x**4*log(x)*log(1+x) + 864*log(x)**2*log(1+x) + & + 864*x*log(x)**2*log(1+x) - 432*x**2*log(x)**2*log(1+x) - 864*x**3*log(x)**2*log(1+x) - & + 432*x**4*log(x)**2*log(1+x)+1296*log(1+x)**2+3456*x*log(1+x)**2 - & + 648*x**2*log(1+x)**2-3456*x**3*log(1+x)**2 - 648*x**4*log(1+x)**2+864*log(x)*log(1+x)**2 + & + 10368*x*log(x)*log(1+x)**2 - 9504*x**2*log(x)*log(1+x)**2 - & + 1728*x**3*log(x)*log(1+x)**2 - 1440*log(1+x)**3 - 4608*x*log(1+x)**3 + & + 3888*x**2*log(1+x)**3 + 288*x**3*log(1+x)**3 + 1872*x**4*log(1+x)**3 - & + 144*(-1+x**2)*(12-12*ln0+4*nlep-15*x-4*nlep*x-24*c_b0*Pi*x+6*x**2+2*nlep*x**2 + & + 12*c_b0*Pi*x**2 + (12+18*x-9*x**2)*log(1-x)+3*(-6+x)*x*log(x))*polylog(2,1-x) + & + 432*(-1+x)*(-12-30*x-25*x**2-3*x**3-8*(1+x)**2*log(x) + & + 2*x*(-12+x+3*x**2)*log(1+x))*polylog(2,-x) + 1728*x*polylog(2,1/(1+x)) - & + 864*x**3*polylog(2,1/(1+x)) - 864*x**4*polylog(2,1/(1+x)) - & + 10368*x*log(1+x)*polylog(2,1/(1+x)) + 7776*x**2*log(1+x)*polylog(2,1/(1+x)) + & + 1728*x**3*log(1+x)*polylog(2,1/(1+x)) + 864*x**4*log(1+x)*polylog(2,1/(1+x)) + & + 2592*polylog(2,x/(1+x)) + 5184*x*polylog(2,x/(1+x)) - 1296*x**2*polylog(2,x/(1+x)) - & + 6048*x**3*polylog(2,x/(1+x)) - 432*x**4*polylog(2,x/(1+x)) + & + 1728*log(x)*polylog(2,x/(1+x)) - 1728*x**2*log(x)*polylog(2,x/(1+x)) + & + 3456*x*log(1+x)*polylog(2,x/(1+x)) - 3456*x**2*log(1+x)*polylog(2,x/(1+x)) - & + 3456*x**3*log(1+x)*polylog(2,x/(1+x)) + 3456*x**4*log(1+x)*polylog(2,x/(1+x)) - & + 4320*x*polylog(3,1-x) + 6480*x**2*polylog(3,1-x) + 7776*x**3*polylog(3,1-x) - & + 3024*x**4*polylog(3,1-x) + 5184*x**2*polylog(3,(-1+x)/x) + 3456*x**3*polylog(3,(-1+x)/x) - & + 1728*x**4*polylog(3,(-1+x)/x) + 1728*polylog(3,x) - 4320*x*polylog(3,x) + & + 5616*x**2*polylog(3,x) + 7776*x**3*polylog(3,x) - 3888*x**4*polylog(3,x) - & + 432*polylog(3,x**2) - 432*x*polylog(3,x**2) + 216*x**2*polylog(3,x**2) + & + 432*x**3*polylog(3,x**2) + 216*x**4*polylog(3,x**2) + 3456*x*polylog(3,x/(1+x)) - & + 1728*x**2*polylog(3,x/(1+x)) - 3456*x**3*polylog(3,x/(1+x)) + 1728*x**4*polylog(3,x/(1+x)) - & + 3456*zeta3 + 2592*x*zeta3 - 864*x**2*zeta3 - 6048*x**3*zeta3 + 864*x**4*zeta3 + jll_nll(6) = (j6_1 + j6_2 + j6_3) / (216._default*x*(-1+x**2)) + end if + end subroutine rechat_photon + +@ %def rechat_photon +@ +<>= + function sum_rm (x, al0_2pi, ln0, cc1, cc2, cc3, cc4, cc5, & + k, m1, m2) result (s_rm) + real(default) :: s_rm + real(default), intent(in) :: x, k, al0_2pi, ln0, m1, m2 + real(default), intent(in) :: cc1, cc2, cc3, cc4, cc5 + real(default) :: f0, f1, f2, fac, den + real(default) :: mf1, mf2, mf3, mf4, mf5 + real(default) :: rr1, rr2, rr3, rr4, rr5 + f0 = two - Pi2/three + three/two * ln0 + f1 = two*(one - ln0) + f2 = - two + den = m2 - m1 * log(1-x) + fac = exp(-eulerc*k) * (1-x)**k / gamma(1+k) + mf1 = one/den - (Pi2*k - 6._default*zeta3 * k**2)*m1/6._default / den**2 & + - (30._default*Pi2 - 360._default*zeta3*k + & + Pi**4 * k**2)*m1**2/180._default / den**3 + mf2 = one + mf3 = - log(1-x) + Pi2*k/6._default - zeta3 * k**2 + mf4 = log(1-x)**2 - Pi2/6._default + k*(-Pi2/three*log(1-x) + two*zeta3) + & + k**2 * (two*zeta3*log(1-x) - Pi**4/180._default) + mf5 = - log(1-x)**3 + Pi2/two*log(1-x) - two*zeta3 + & + k*(Pi2/two*log(1-x)**2 - 6._default*zeta3*log(1-x) - & + Pi**4/60._default) + k**2 * (-three*zeta3*log(1-x)**2 + & + Pi**4/60._default*log(1-x) + three/two*Pi2*zeta3 - 12._default*zeta5) + rr1 = (cc3 - cc4*cc2 + cc4**2 * cc1) * & + (one + al0_2pi * (f0 - cc4*f1 + cc4**2 * f2)) + rr2 = (cc2 - cc4*cc1) / cc5 + al0_2pi/cc5 * (cc2*f0 + cc3*f1 - & + cc4*(cc1*f0 + cc2*f1 + cc3*f2) + cc4**2 * (cc1*f1 + cc2*f2) - & + cc4**3 * cc1 * f2) + rr3 = cc1/cc5 + al0_2pi/cc5 * (cc1*f0 + cc2*f1 + cc3*f2 - & + cc4*(cc1*f1 + cc2*f2) + cc4**2 * cc1 * f2) + rr4 = al0_2pi * 1/cc5 * (cc1*f1 + cc2*f2 - cc4*cc1*f2) + rr5 = al0_2pi * cc1/cc5 * f2 + s_rm = fac * (rr1*mf1 + rr2*mf2 + rr3*mf3 + rr4*mf4 + rr5*mf5) + end function sum_rm + +@ %def sum_rm +@ For the moment, the number of quark flavors in the running of +$alpha$ is set equal to zero. +<>= + public :: t_alpha +<>= + module function t_alpha (epdf, scale) result (t) + real(default) :: t + type(qed_pdf_t), intent(in) :: epdf + real(default), intent(in) :: scale + end function t_alpha +<>= + module function t_alpha (epdf, scale) result (t) + real(default) :: t + type(qed_pdf_t), intent(in) :: epdf + real(default), intent(in) :: scale + real(default) :: alphamu, alpharef + select type (alpha => epdf%aqed) + type is (alpha_qed_from_scale_t) + alpharef = alpha%ref + alphamu = alpha%get (scale) + type is (alpha_qed_fixed_t) + call msg_fatal & + ("t integrator: has to be called with running alpha.") + end select + t = - log (alphamu/alpharef) / two / Pi / coeffqed_b0 (0, epdf%n_lep) + end function t_alpha + +@ %def t_alpha +@ +<>= + function rec_series (p, al_2pi, expansion) result (rec) + real(default) :: rec + real(default), intent(in) :: p, al_2pi + real(default), dimension(6) :: expansion + rec = expansion(1) * p + expansion(2) * p**2 / two + & + expansion(3) * p**3/6._default + al_2pi * (expansion(4) + & + expansion(5) * p + expansion(6) * p**2 / two) + end function rec_series + +@ %def rec_series +@ +<>= + function f_lim_1 (x) result (f) + real(default), intent(in) :: x + real(default) :: xb, f + xb = one - x + f = two * log(xb)**2 + (two/three)*Pi2 * log(xb) + & + (two/three)*Pi2 - four * zeta3 + end function f_lim_1 + +@ %def f_lim_1 +@ +<>= + function f_lim_2 (x) result (f) + real(default), intent(in) :: x + real(default) :: xb, f + xb = one - x + f = -two*log(xb)**2 + (two - two/three*Pi2) * log(xb) + & + (Pi2/three) + four*zeta3 + end function f_lim_2 + +@ %def f_lim_2 +@ +@ The functions for the numeric integrations are of the form +$f_N(x) = \int_0^1 dy \tilde{f}_N(y,x)$. +<>= + function func_1 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = ((2 + (-1 + x)*y*(2 + (-1 + x)*y)) * & + ((1 + (-1 + x)*y)*log(1 - x)* & + ((-1 + x)*log(1 - x) + 2*x*log(x)) - & + 2*x*log(x/(1 + (-1 + x)*y))* & + log(1 - x/(1 + (-1 + x)*y)) + & + (-1 + x)*(-1 + y)* & + log(1 - x/(1 + (-1 + x)*y))**2))/ & + ((-1 + x)*x*y*(1 + (-1 + x)*y)) + & + 2*(1 + (-1 + x)*y)* & + (log(1 - x)**2*log(x) - & + log(x/(1 + (-1 + x)*y))* & + log(one - x/(one + (-one + x)*y))**2) - & + f_lim_1 (x) + end function func_1 + +@ %def func_1 +@ +<>= + function func_2 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = -(((2 + 2*y*(-1 + x) + y**2*(-1 + x)**2) * & + ((-1 + x)*((1 + y*(-1 + x))*log(1 - x)**2 + & + (-1 + y)*log(((-1 + y)*(-1 + x))/(1 + y*(-1 + x)))**2) & + - (x + y*(-1 + x)*x)*polylog(2,x) + & + x*polylog(2,x/(1 + y*(-1 + x)))))/(y*(1 + & + y*(-1 + x))*(-1 + x)*x)) + 2*(1 + y*(-1 + x)) * & + (log(1 - x)*polylog(2,x) - log(((-1 + y)*(-1 + x)) / & + (1 + y*(-1 + x)))*polylog(2,x/(1 + y*(-1 + x)))) - & + f_lim_2(x) + end function func_2 + +@ %def func_2 +@ +<>= + function func_3 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = ((2 + 2*y*(-1 + x) + y**2*(-1 + x)**2) * & + ((1 + y*(-1 + x))*polylog(2,1 - x) - & + polylog(2,((-1 + y)*(-1 + x))/(1 + y*(-1 + x))))) / & + (y*(1 + y*(-1 + x))*(-1 + x)) + 2*(1 + y*(-1 + x)) * & + (polylog(3,1 - x) - polylog(3,((-1 + y)*(-1 + x)) / & + (1 + y*(-1 + x)))) + two + end function func_3 + +@ %def func_3 +@ +<>= + function func_4 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = two*(1 + y*(-1 + x))*(log(x)**2*log(1 + x) - & + log(x/(1 + y*(-1 + x)))**2*log(1 + x/(1 + y*(-1 + x)))) - & + ((1 + (1 + y*(-1 + x))**2) * (-(log(x)**2/(1 + x)) - & + (2*log(x)*log(1 + x))/x - ((-1 + y)*log(x/(1 + y*(-1 + x))) * & + (x*log(x/(1 + y*(-1 + x))) + 2*(1 + y*(-1 + x) + x) * & + log(1 + x/(1 + y*(-1 + x))))) / ((1 + y*(-1 + x)) * x * & + (1 + y*(-1 + x) + x))))/y + end function func_4 + +@ %def func_4 +@ +<>= + function func_5 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = -(((1 + (1 + y*(-1 + x))**2) * ((-2*log(x)*log(1 + x)) / & + (1 + x) - log(1 + x)**2/x - (2*(-1 + y)*log(x/(1 + & + y*(-1 + x)))*log(1 + x/(1 + y*(-1 + x)))) / ((1 + & + y*(-1 + x))*(1 + y*(-1 + x) + x)) - ((-1 + y) * & + log(1 + x/(1 + y*(-1 + x)))**2)/(x + y*(-1 + x)*x)))/y) + & + 2*(1 + y*(-1 + x))*(log(x)*log(1 + x)**2 - log(x/(1 + & + y*(-1 + x))) * log(1 + x/(1 + y*(-1 + x)))**2) - & + two*log(two)**2 + end function func_5 + +@ %def func_5 +@ +<>= + function func_8 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = -(((2 + 2*y*(-1 + x) + y**2*(-1 + x)**2)*(log(x)*log(1 + x) - & + y*log(x)*log(1 + x) + y*x*log(x)*log(1 + x) - log(x/(1 + & + y*(-1 + x)))*log(1 + x/(1 + y*(-1 + x))) + y*log(x/(1 + & + y*(-1 + x)))*log(1 + x/(1 + y*(-1 + x))) + (-1 + y - y*x) * & + polylog(2,-x) - (-1 + y)*polylog(2,-(x/(1 + y*(-1 + x)))))) / & + (y*(1 + y*(-1 + x))*x)) + 2*(1 + y*(-1 + x))*(log(x) * & + polylog(2,-x) - log(x/(1 + y*(-1 + x))) * & + polylog(2,-(x/(1 + y*(-1 + x))))) + Pi2/6._default + end function func_8 + +@ %def func_6 +@ +<>= + function func_9 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = -(((1 + (1 + y*(-1 + x))**2) * (log(1 + x)**2 / x + & + ((-1 + y)*log(1 + x/(1 + y*(-1 + x)))**2) / (x + & + y*(-1 + x)*x) - polylog(2,-x)/(1 + x) - ((-1 + y) * & + polylog(2,-(x/(1 + y*(-1 + x))))) / ((1 + y*(-1 + x)) * & + (1 + y*(-1 + x) + x))))/y) + 2*(1 + y*(-1 + x)) * & + (log(1 + x)*polylog(2,-x) - log(1 + x/(1 + y*(-1 + x))) * & + polylog(2,-(x/(1 + y*(-1 + x))))) + Pi2/12._default + & + two*log(two)**2 + end function func_9 + +@ %def func_9 +@ +<>= + function func_10 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = -(((1 + (1 + y*(-1 + x))**2) * (-((log(x/(1 + x)) * & + log(1 + x))/(1 + x)) - ((-1 + y) * & + log(x/(1 + y*(-1 + x) + x))*log(1 + x/(1 + y*(-1 + x)))) / & + ((1 + y*(-1 + x))*(1 + y*(-1 + x) + x)) - & + polylog(2,1/(1 + x))/(1 + x) - ((-1 + y) * & + polylog(2,1/(1 + x/(1 + y*(-1 + x))))) / & + ((1 + y*(-1 + x))*(1 + y*(-1 + x) + x))))/y) + & + 2*(1 + y*(-1 + x))*(log(1 + x)*polylog(2,one/(1 + x)) - & + log(1 + x/(1 + y*(-1 + x))) * polylog(2,one/(1 + x/(1 + y*(-1 + x))))) - & + Pi2/12._default + three/two*log(two)**2 + end function func_10 + +@ %def func_10 +@ +<>= + function func_11 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = ((2 + 2*y*(-1 + x) + y**2*(-1 + x)**2)*((1 + & + y*(-1 + x))*polylog(2,-x) + (-1 + y) * & + polylog(2,-(x/(1 + y*(-1 + x)))))) / (y*(1 + & + y*(-1 + x))*x) + 2*(1 + y*(-1 + x))*(polylog(3,-x) - & + polylog(3,-(x/(1 + y*(-1 + x))))) + Pi2/6._default + end function func_11 + +@ %def func_11 +@ +<>= + function func_12 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = -(((1 + (1 + y*(-1 + x))**2)*(polylog(2,1/(1 + x))/(1 + x) + & + ((-1 + y)*polylog(2,1/(1 + x/(1 + y*(-1 + x))))) / & + ((1 + y*(-1 + x))*(1 + y*(-1 + x) + x))))/y) + 2*(1 + & + y*(-1 + x))*(polylog(3,1/(1 + x)) - & + polylog(3,1/(1 + x/(1 + y*(-1 + x))))) + Pi2/12._default - & + 0.5_default*log(two)**2 + end function func_12 + +@ %def func_12 +@ +<>= + function func_13 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = -(((2 + 2*y*(-1 + x) + y**2*(-1 + x)**2)*log((1 - y) / & + (1 + y*(-1 + x)))*log(1 + y*(-1 + x)))/(y*(-1 + x))) - & + ((2 + 2*y*(-1 + x) + y**2*(-1 + x)**2)*log((1 - y) / & + (1 + y*(-1 + x)))*log(y - y*x))/(1 + y*(-1 + x)) + & + ((2 + 2*y*(-1 + x) + y**2*(-1 + x)**2)*log(1 + & + y*(-1 + x))*log(y - y*x))/(1 + y*(-1 + x)) - 2*(1 + & + y*(-1 + x))*log((1 - y)/(1 + y*(-1 + x)))*log(1 + & + y*(-1 + x))*log(y - y*x) - two*log(1-x) + two - Pi2/three + end function func_13 + +@ %def func_13 +@ +<>= + function func_14 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = (log(1 + y*(-1 + x)) * (((2 + y*(-1 + x))*(2 + & + 2*y*(-1 + x) + y**2*(-1 + x)**2)*log(1 + & + y*(-1 + x)))/(1 + y*(-1 + x)) + (2*y*(2 + & + y*(-1 + x))*(2 + 2*y*(-1 + x) + y**2*(-1 + x)**2) * & + (-1 + x) * log(((-1 + y)*(-1 + x))/(1 + & + y*(-1 + x)))) / (1 + y*(-1 + x)) + (1 + (1 + & + y*(-1 + x))**2)*(2 + y*(-1 + x)) * log(1 + y*(-1 + x)) * & + log(((-1 + y)*(-1 + x))/(1 + y*(-1 + x))) + & + y*(1 + (1 + y*(-1 + x))**2)*(1 - x)* log(1 + y*(-1 + x)) * & + log(((-1 + y)*(-1 + x))/(1 + y*(-1 + x))) + & + 2*y*(1 + y*(-1 + x))*(2 + y*(-1 + x))*(-1 + x) * & + log(1 + y*(-1 + x)) * log(((-1 + y)*(-1 + x)) / & + (1 + y*(-1 + x))))) / (2 + y*(-1 + x))**2 + end function func_14 + +@ %def func_14 +@ +<>= + function func_15 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = (((2 + y*(-1 + x))*(2 + 2*y*(-1 + x) + & + y**2*(-1 + x)**2)*log(1 + y*(-1 + x))*log(2 + & + y*(-1 + x)))/(1 + y*(-1 + x)) - y*(1 + (1 + & + y*(-1 + x))**2)*(1 - x)*log(1 + y*(-1 + x)) * & + log(((-1 + y)*(-1 + x))/(1 + y*(-1 + x))) + & + (y*(2 + y*(-1 + x))*(2 + 2*y*(-1 + x) + & + y**2*(-1 + x)**2)*(-1 + x)*log(2 + y*(-1 + x)) * & + log(((-1 + y)*(-1 + x))/(1 + y*(-1 + x)))) / & + (1 + y*(-1 + x)) + (1 + (1 + y*(-1 + x))**2) * & + (2 + y*(-1 + x))*log(1 + y*(-1 + x))*log(2 + & + y*(-1 + x))*log(((-1 + y)*(-1 + x))/(1 + y*(-1 + x))) + & + y*(1 + (1 + y*(-1 + x))**2)*(1 - x)*log(1 + & + y*(-1 + x))*log(2 + y*(-1 + x))*log(((-1 + y) * & + (-1 + x))/(1 + y*(-1 + x))) + 2*y*(1 + y*(-1 + & + x))*(2 + y*(-1 + x))*(-1 + x)*log(1 + y*(-1 + x)) * & + log(2 + y*(-1 + x))*log(((-1 + y)*(-1 + x)) / & + (1 + y*(-1 + x)))) / (2 + y*(-1 + x))**2 + end function func_15 + +@ %def func_15 +@ +<>= + function func_16 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = (-((y*(2 + y*(-1 + x))*(2 + 2*y*(-1 + x) + y**2*(-1 + x)**2) * & + (-1 + x)*log(2 + y*(-1 + x))*log(((-1 + y)*(-1 + x))/(1 + & + y*(-1 + x))))/(1 + y*(-1 + x))) + ((2 + y*(-1 + x))*(2 + & + 2*y*(-1 + x) + y**2*(-1 + x)**2)*polylog(2,-1 + y - y*x)) / & + (1 + y*(-1 + x)) + (1 + (1 + y*(-1 + x))**2)*(2 + y*(-1 + & + x))*log(((-1 + y)*(-1 + x))/(1 + y*(-1 + x))) * & + polylog(2,-1 + y - y*x) + y*(1 + (1 + y*(-1 + x))**2) * & + (1 - x)*log(((-1 + y)*(-1 + x))/(1 + y*(-1 + x))) * & + polylog(2,-1 + y - y*x) + 2*y*(1 + y*(-1 + x))*(2 + & + y*(-1 + x))*(-1 + x)*log(((-1 + y)*(-1 + x))/(1 + & + y*(-1 + x)))*polylog(2,-1 + y - y*x))/(2 + y*(-1 + x))**2 + & + Pi2/12._default*log(xb) + end function func_16 + +@ %def func_16 +@ +<>= + function func_20 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = polylog(2,((-1 + y)*(-1 + x))/(1 + y*(-1 + x))) / (1 + y*(-1 + x)) + & + polylog(3,((-1 + y)*(-1 + x))/(1 + y*(-1 + x))) + end function func_20 + +@ %def func_20 +@ +<>= + function func_24 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = (log(1 + x/(1 + y*(-1 + x)))*(-((-1 + y)*(-1 + x)*(1 + y*(-1 + x) + x) * & + log(1 + x/(1 + y*(-1 + x)))) + x*log(x/(1 + y*(-1 + x)))*(2*(-1 + y + & + x - y*x) + (1 + y*(-1 + x) + x)*log(1 + x/(1 + y*(-1 + x)))))) / & + ((1 + y*(-1 + x))**2*x*(1 + y*(-1 + x) + x)) + end function func_24 + +@ %def func_24 +@ +<>= + function func_25 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = (((-1 + y)*(-1 + x)*log(1 + x/(1 + y*(-1 + x)))**2)/x + ((-1 + y + x - & + y*x + (1 + y*(-1 + x) + x)*log(1 + x/(1 + y*(-1 + x)))) * & + polylog(2,-(x/(1 + y*(-1 + x))))) / (1 + y*(-1 + x) + x)) / & + (1 + y*(-1 + x))**2 + Pi2/12._default * log(two) + end function func_25 + +@ %def func_25 +@ +<>= + function func_30 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = ((-1 + y + x - y*x)*log(x/(1 + y*(-1 + x) + x)) * log(1 + x/(1 + & + y*(-1 + x))) + (-1 + y + x - y*x + (1 + y*(-1 + x) + x)*log(1 + & + x/(1 + y*(-1 + x))))*polylog(2,1/(1 + x/(1 + y*(-1 + x))))) / & + ((1 + y*(-1 + x))**2*(1 + y*(-1 + x) + x)) - Pi2/12._default*log(two) + & + 0.5*log(two)**3 + end function func_30 + +@ %def func_30 +@ +<>= + function func_32 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = (polylog(2,((-1 + y)*(-1 + x))/(1 + y*(-1 + x))) + & + polylog(3,((-1 + y)*(-1 + x))/(1 + y*(-1 + x)))) / & + (1 + y*(-1 + x))**2 + end function func_32 + +@ %def func_32 +@ +<>= + function func_34 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = ((-1 + y)*(-1 + x)*polylog(2,1/(1 + x/(1 + y*(-1 + x))))) / & + ((1 + y*(-1 + x))*(1 + y*(-1 + x) + x)) + polylog(3,1/(1 + & + x/(1 + y*(-1 + x)))) - one/6._default*log(two)**3 + & + Pi2/12._default*log(two) - 7._default/8._default*zeta3 + end function func_34 + +@ %def func_34 +@ +<>= + function func_35 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = ((-1 + y)*(-1 + x)*polylog(2,1/(1 + x/(1 + y*(-1 + x)))) + & + (1 + y*(-1 + x) + x)*polylog(3,1/(1 + x/(1 + y*(-1 + x))))) / & + ((1 + y*(-1 + x))**2*(1 + y*(-1 + x) + x)) - & + one/6._default*log(two)**3 + Pi2/12._default*log(two) - & + 7._default/8._default*zeta3 + end function func_35 + +@ %def func_35 +@ +<>= + function func_37 (y, x) result (f) + real(default), intent(in) :: x, y + real(default) :: xb, f + xb = one - x + f = (log(y - y*x)*(log(y - y*x) + log(((-1 + y)*(-1 + x)) / & + (1 + y*(-1 + x)))*(2 + 2*y*(-1 + x) + log(y - y*x)))) / & + (1 + y*(-1 + x))**2 - log(xb)**3 + Pi2/three*log(xb) - two*zeta3 + end function func_37 + +@ %def func_37 +@ +<>= + public :: endpoint_func_S +<>= + module function endpoint_func_S (x, nlep) result (f) + real(default), intent(in) :: x + integer, intent(in) :: nlep + real(default) :: f + end function endpoint_func_S +<>= + module function endpoint_func_S (x, nlep) result (f) + real(default), intent(in) :: x + integer, intent(in) :: nlep + real(default) :: f + real(default) :: result, abserr + real(default), parameter :: epsabs = 0.001_default, & + epsrel = 0.001_default + real(default), parameter :: a = 0._default, b = 1._default + integer, parameter :: limit = 10000 + call gauss_kronrod (GAUSS_KRONROD_41, int_fun, a, b, & + limit, result, abserr, epsabs, epsrel) + f = result + contains + function int_fun (y) result (d_f) + real(default) :: d_f + real(default), intent(in) :: y + d_f = four*func_1(y,x) + four*func_2(y,x) + four*func_3(y,x) - & + two*func_4(y,x) - four*func_5(y,x) - four*func_8(y,x) - & + four*func_9(y,x) + four*func_10(y,x) + 4.*func_11(y,x) - & + 8._default*func_12(y,x) - four*func_13(y,x) + two*func_14(y,x) - & + 8._default*func_15(y,x) - 8._default*func_16(y,x) - & + 24._default*real(nlep,kind=default)*func_20(y,x); + end function int_fun + end function endpoint_func_S + +@ %def endpoint_func_S +@ +<>= + public :: endpoint_func_NS +<>= + module function endpoint_func_NS (x) result (f) + real(default), intent(in) :: x + real(default) :: f + end function endpoint_func_NS +<>= + module function endpoint_func_NS (x) result (f) + real(default), intent(in) :: x + real(default) :: f + real(default) :: result, abserr + real(default), parameter :: epsabs = 0.001_default, & + epsrel = 0.001_default + real(default), parameter :: a = 0._default, b = 1._default + integer, parameter :: limit = 10000 + call gauss_kronrod (GAUSS_KRONROD_41, int_fun, a, b, & + limit, result, abserr, epsabs, epsrel) + f = result + contains + function int_fun (y) result (d_f) + real(default) :: d_f + real(default), intent(in) :: y + d_f = four*func_1(y,x) + four*func_2(y,x) + four*func_3(y,x) + & + two*func_4(y,x) + four*func_5(y,x) + four*func_8(y,x) + & + four*func_9(y,x) - four*func_10(y,x) - four*func_11(y,x) + & + 8._default*func_12(y,x) - four*func_13(y,x) - two*func_14(y,x) + & + 8._default*func_15(y,x) + 8._default*func_16(y,x) + end function int_fun + end function endpoint_func_NS + +@ %def endpoint_func_NS +@ +<>= + public :: endpoint_func_GAM +<>= + module function endpoint_func_GAM (x) result (f) + real(default), intent(in) :: x + real(default) :: f + end function endpoint_func_GAM +<>= + module function endpoint_func_GAM (x) result (f) + real(default), intent(in) :: x + real(default) :: f + real(default) :: result, abserr + real(default), parameter :: epsabs = 0.001_default, & + epsrel = 0.001_default + real(default), parameter :: a = 0._default, b = 1._default + integer, parameter :: limit = 10000 + call gauss_kronrod (GAUSS_KRONROD_41, int_fun, a, b, & + limit, result, abserr, epsabs, epsrel) + f = result + contains + function int_fun (y) result (d_f) + real(default) :: d_f + real(default), intent(in) :: y + d_f = -8._default*func_24(y,x) - 8._default*func_25(y,x) + & + 8._default*func_30(y,x) + 8._default*func_32(y,x) + 16._default* & + func_34(y,x) - 16._default*func_35(y,x) - four*func_37(y,x) + end function int_fun + end function endpoint_func_GAM + +@ %def endpoint_func_GAM +@ +<>= + function photon_matching (x, x0, x1, p) result (p_match) + real(default) :: p_match + real(default), intent(in) :: x, x0, x1, p + real(default) :: xm, logx + logx = - log10(1-x) + if (logx < x0) then + p_match = zero + else if (logx > x1) then + p_match = one + else + xm = (logx - x0) / (x1 - x0) + p_match = xm**p / (xm**p + (1-xm)**p) + end if + end function photon_matching +<>= + public :: elec_pdf +<>= + module function elec_pdf (epdf, flv, x, scale, alpha, & + running, w_num) result (e_pdf) + type(qed_pdf_t), intent(in) :: epdf + integer, intent(in) :: flv + real(default) :: e_pdf + real(default), intent(in) :: x + real(default), intent(in) :: scale + real(default), intent(in) :: alpha + logical, intent(in) :: running, w_num + end function elec_pdf +<>= + module function elec_pdf (epdf, flv, x, scale, alpha, & + running, w_num) result (e_pdf) + type(qed_pdf_t), intent(in) :: epdf + integer, intent(in) :: flv + real(default) :: e_pdf + real(default), intent(in) :: x + real(default), intent(in) :: scale + real(default), intent(in) :: alpha + logical, intent(in) :: running, w_num + integer :: nlep + real(default) :: ln0, eta0, al_2pi, p + real(default), parameter :: x0gam = 2.0_default, x1gam = & + 6._default, pgam = 2._default + if (allocated (epdf%q_in)) then + ln0 = log(epdf%q_in**2/epdf%mass**2) + eta0 = alpha/Pi * log(scale**2/epdf%q_in**2) + else + ln0 = zero + eta0 = alpha/Pi * log(scale**2/epdf%mass**2) + end if + if (running) then + p = t_alpha (epdf, scale) + else + p = eta0 / two + end if + select case (epdf%log_order) + case (EPDF_LL) + nlep = epdf%n_lep + al_2pi = zero + case (EPDF_NLL) + if (running) then + select type (aqed => epdf%aqed) + type is (alpha_qed_from_scale_t) + nlep = aqed%nlep + al_2pi = aqed%get (scale) / two / Pi + type is (alpha_qed_fixed_t) + call msg_fatal & + ("elec_pdf: has to be called with running alpha.") + end select + else + nlep = epdf%n_lep + al_2pi = alpha / two / Pi + end if + end select + select case (flv) + case (EPDF_S) + e_pdf = elec_asym (epdf, x, scale, alpha, running) + & + recbar (epdf, flv, x, scale, alpha, running) + & + rechat (epdf, flv, x, scale, alpha, running) - & + bar_asym (epdf, flv, x, scale, alpha, running) + if (w_num) then + e_pdf = e_pdf + & + rec_num (epdf, flv, x, scale, alpha, running) + end if + case (EPDF_NS) + e_pdf = elec_asym (epdf, x, scale, alpha, running) + & + recbar (epdf, flv, x, scale, alpha, running) + & + rechat (epdf, flv, x, scale, alpha, running) - & + bar_asym (epdf, flv, x, scale, alpha, running) + if (w_num) then + e_pdf = e_pdf + & + rec_num (epdf, flv, x, scale, alpha, running) + end if + case (EPDF_G) + e_pdf = recbar (epdf, flv, x, scale, alpha, running) + & + rechat (epdf, flv, x, scale, alpha, running) + & + photon_matching (x, x0gam, x1gam, pgam) * & + (phot_asym (epdf, x, scale, alpha, nlep, running) - & + recbar (epdf, flv, x, scale, alpha, running)) + if (w_num) then + e_pdf = e_pdf + & + rec_num (epdf, flv, x, scale, alpha, running) + end if + case (EPDF_ELE) + e_pdf = elec_asym (epdf, x, scale, alpha, running) - & + bar_asym (epdf, EPDF_S, x, scale, alpha, running) + & + 0.5_default * (recbar (epdf, EPDF_S, x, scale, alpha, running) + & + recbar (epdf, EPDF_NS, x, scale, alpha, running) + & + rechat (epdf, EPDF_S, x, scale, alpha, running) + & + rechat (epdf, EPDF_NS, x, scale, alpha, running)) + if (w_num) then + e_pdf = e_pdf + 0.5_default * ( & + rec_num (epdf, EPDF_S, x, scale, alpha, running) + & + rec_num (epdf, EPDF_NS, x, scale, alpha, running)) + end if + case (EPDF_POS) + e_pdf = 0.5_default * (recbar (epdf, EPDF_S, x, scale, alpha, running) - & + recbar (epdf, EPDF_NS, x, scale, alpha, running) + & + rechat (epdf, EPDF_S, x, scale, alpha, running) - & + rechat (epdf, EPDF_NS, x, scale, alpha, running)) + if (w_num) then + e_pdf = e_pdf + 0.5_default * ( & + rec_num (epdf, EPDF_S, x, scale, alpha, running) - & + rec_num (epdf, EPDF_NS, x, scale, alpha, running)) + end if + case default + call msg_fatal & + ("elec_pdf: wrong lepton flavor.") + end select + end function elec_pdf + +@ %def elec_pdf +@ +\subsection{Unit tests} +Test module, followed by the corresponding implementation module. +<<[[electron_pdfs_ut.f90]]>>= +<> + +module electron_pdfs_ut + use unit_tests + use electron_pdfs_uti + +<> + +<> + +contains + +<> + +end module electron_pdfs_ut +@ %def electron_pdfs_ut +@ +<<[[electron_pdfs_uti.f90]]>>= +<> + +module electron_pdfs_uti + +<> + use numeric_utils + use format_defs, only: FMT_15 + use constants + use physics_defs, only: ME_REF, ALPHA_QED_ME_REF + use electron_pdfs + +<> + +<> + +contains + +<> + +end module electron_pdfs_uti +@ %def electron_pdfs_ut +@ API: driver for the unit tests below. +<>= + public :: electron_pdfs_test +<>= + subroutine electron_pdfs_test (u, results) + integer, intent(in) :: u + type(test_results_t), intent(inout) :: results + <> + end subroutine electron_pdfs_test + +@ %def electron_pdfs_test +@ +\subsubsection{Electron PDF tests} +<>= + call test (electron_pdfs_1, "electron_pdfs_1", & + "Electron PDFs: auxiliary functions", & + u, results) +<>= + public :: electron_pdfs_1 +<>= + subroutine electron_pdfs_1 (u) + integer, intent(in) :: u + type(qed_pdf_t) :: pdf + real(default) :: Q, alpha + real(default) :: x1, x2, x3, x4 + integer :: n_lep + Q = 10._default + x1 = 0.1_default + x2 = 0.5_default + x3 = 0.9_default + x4 = 0.999_default + alpha = ALPHA_QED_ME_REF + n_lep = 1 + + write (u, "(A)") "* Test output: electron_pdfs_1" + write (u, "(A)") "* Purpose: check analytic properties" + write (u, "(A)") + + write (u, "(A)") "* Auxiliary functions I:" + write (u, "(A)") + + write (u, "(A)") "* Q = 10 GeV, elec_asym, LL+NLL, alpha fixed:" + write (u, "(A)") + + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 0, 1) + write (u, "(1x,A,F9.6)") " elec_asym (LL,x=0.1) = ", & + elec_asym (pdf, x1, Q, alpha, .false.) + write (u, "(1x,A,F9.6)") " elec_asym (LL,x=0.5) = ", & + elec_asym (pdf, x2, Q, alpha, .false.) + write (u, "(1x,A,F9.6)") " elec_asym (LL,x=0.9) = ", & + elec_asym (pdf, x3, Q, alpha, .false.) + write (u, "(1x,A,F9.6)") " elec_asym (LL,x=0.999) = ", & + elec_asym (pdf, x4, Q, alpha, .false.) + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, 1) + write (u, "(A)") + write (u, "(1x,A,F9.6)") " elec_asym (NLL,x=0.1) = ", & + elec_asym (pdf, x1, Q, alpha, .false.) + write (u, "(1x,A,F9.6)") " elec_asym (NLL,x=0.5) = ", & + elec_asym (pdf, x2, Q, alpha, .false.) + write (u, "(1x,A,F9.6)") " elec_asym (NLL,x=0.9) = ", & + elec_asym (pdf, x3, Q, alpha, .false.) + write (u, "(1x,A,F9.6)") " elec_asym (NLL,x=0.999) = ", & + elec_asym (pdf, x4, Q, alpha, .false.) + + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 0, 1) + call pdf%allocate_aqed (order = 0, n_f = 0, n_lep = 1, running = .true.) + write (u, "(A)") + call pdf%write (u, with_qed = .true.) + write (u, "(A)") + + write (u, "(A)") "* Q = 10 GeV, elec_asym, LL+NLL, alpha running:" + write (u, "(A)") + + write (u, "(1x,A,F9.6)") " Integrator t (10 GeV) = ", & + t_alpha (pdf, Q) + write (u, "(A)") + + write (u, "(1x,A,F9.6)") " elec_asym (LL,x=0.1) = ", & + elec_asym (pdf, x1, Q, alpha, .true.) + write (u, "(1x,A,F9.6)") " elec_asym (LL,x=0.5) = ", & + elec_asym (pdf, x2, Q, alpha, .true.) + write (u, "(1x,A,F9.6)") " elec_asym (LL,x=0.9) = ", & + elec_asym (pdf, x3, Q, alpha, .true.) + write (u, "(1x,A,F9.6)") " elec_asym (LL,x=0.999) = ", & + elec_asym (pdf, x4, Q, alpha, .true.) + write (u, "(A)") + + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, 1) + call pdf%allocate_aqed (order = 1, n_f = 0, n_lep = 1, running = .true.) + write (u, "(1x,A,F9.6)") " elec_asym (NLL,x=0.1) = ", & + elec_asym (pdf, x1, Q, alpha, .true.) + write (u, "(1x,A,F9.6)") " elec_asym (NLL,x=0.5) = ", & + elec_asym (pdf, x2, Q, alpha, .true.) + write (u, "(1x,A,F9.6)") " elec_asym (NLL,x=0.9) = ", & + elec_asym (pdf, x3, Q, alpha, .true.) + write (u, "(1x,A,F9.6)") " elec_asym (NLL,x=0.999) = ", & + elec_asym (pdf, x4, Q, alpha, .true.) + + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, phot_asym, LL+NLL, alpha fixed:" + write (u, "(A)") + + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 0, 1) + write (u, "(1x,A,F9.6)") " phot_asym (LL,x=0.1) = ", & + phot_asym (pdf, x1, Q, alpha, n_lep, .false.) + write (u, "(1x,A,F9.6)") " phot_asym (LL,x=0.5) = ", & + phot_asym (pdf, x2, Q, alpha, n_lep, .false.) + write (u, "(1x,A,F9.6)") " phot_asym (LL,x=0.9) = ", & + phot_asym (pdf, x3, Q, alpha, n_lep, .false.) + write (u, "(1x,A,F9.6)") " phot_asym (LL,x=0.999) = ", & + phot_asym (pdf, x4, Q, alpha, n_lep, .false.) + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, 1) + write (u, "(A)") + write (u, "(1x,A,F9.6)") " phot_asym (NLL,x=0.1) = ", & + phot_asym (pdf, x1, Q, alpha, n_lep, .false.) + write (u, "(1x,A,F9.6)") " phot_asym (NLL,x=0.5) = ", & + phot_asym (pdf, x2, Q, alpha, n_lep, .false.) + write (u, "(1x,A,F9.6)") " phot_asym (NLL,x=0.9) = ", & + phot_asym (pdf, x3, Q, alpha, n_lep, .false.) + write (u, "(1x,A,F9.6)") " phot_asym (NLL,x=0.999) = ", & + phot_asym (pdf, x4, Q, alpha, n_lep, .false.) + + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, phot_asym, LL+NLL, alpha running:" + write (u, "(A)") + + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 0, 1) + call pdf%allocate_aqed (order = 0, n_f = 0, n_lep = 1, running = .true.) + write (u, "(1x,A,F9.6)") " phot_asym (LL,x=0.1) = ", & + phot_asym (pdf, x1, Q, alpha, n_lep, .true.) + write (u, "(1x,A,F9.6)") " phot_asym (LL,x=0.5) = ", & + phot_asym (pdf, x2, Q, alpha, n_lep, .true.) + write (u, "(1x,A,F9.6)") " phot_asym (LL,x=0.9) = ", & + phot_asym (pdf, x3, Q, alpha, n_lep, .true.) + write (u, "(1x,A,F9.6)") " phot_asym (LL,x=0.999) = ", & + phot_asym (pdf, x4, Q, alpha, n_lep, .true.) + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, 1) + call pdf%allocate_aqed (order = 1, n_f = 0, n_lep = 1, running = .true.) + write (u, "(A)") + write (u, "(1x,A,F9.6)") " phot_asym (NLL,x=0.1) = ", & + phot_asym (pdf, x1, Q, alpha, n_lep, .true.) + write (u, "(1x,A,F9.6)") " phot_asym (NLL,x=0.5) = ", & + phot_asym (pdf, x2, Q, alpha, n_lep, .true.) + write (u, "(1x,A,F9.6)") " phot_asym (NLL,x=0.9) = ", & + phot_asym (pdf, x3, Q, alpha, n_lep, .true.) + write (u, "(1x,A,F9.6)") " phot_asym (NLL,x=0.999) = ", & + phot_asym (pdf, x4, Q, alpha, n_lep, .true.) + + write (u, "(A)") + write (u, "(A)") "* Test output end: electron_pdfs_1" + + end subroutine electron_pdfs_1 + +@ %def electron_pdfs_1 +@ +<>= + call test (electron_pdfs_2, "electron_pdfs_2", & + "Electron PDFs: auxiliary functions (2)", & + u, results) +<>= + public :: electron_pdfs_2 +<>= + subroutine electron_pdfs_2 (u) + integer, intent(in) :: u + real(default) :: Q, alpha + real(default) :: x1, x2, x3, x4, ln0 + real(default), dimension(6):: jll_nll + logical, dimension(6) :: order + integer :: n_lep + Q = 10._default + x1 = 0.1_default + x2 = 0.5_default + x3 = 0.9_default + x4 = 0.999_default + ln0 = 0._default + n_lep = 1 + order = .true. + + write (u, "(A)") "* Test output: electron_pdfs_2" + write (u, "(A)") "* Purpose: check analytic properties" + write (u, "(A)") + + write (u, "(A)") "* Auxiliary functions II:" + write (u, "(A)") + + write (u, "(A)") "* Q = 10 GeV, elecbar_asym_p, LL+NLL, alpha fixed:" + write (u, "(A)") + call elecbar_asym_p (x1, jll_nll, n_lep, ln0, order, running=.false.) + write (u, "(1x,A,6(1x,ES11.4))") " elecbar_asym_p (x=0.100) = ", jll_nll + call elecbar_asym_p (x2, jll_nll, n_lep, ln0, order, running=.false.) + write (u, "(1x,A,6(1x,ES11.4))") " elecbar_asym_p (x=0.500) = ", jll_nll + call elecbar_asym_p (x3, jll_nll, n_lep, ln0, order, running=.false.) + write (u, "(1x,A,6(1x,ES11.4))") " elecbar_asym_p (x=0.900) = ", jll_nll + call elecbar_asym_p (x4, jll_nll, n_lep, ln0, order, running=.false.) + write (u, "(1x,A,6(1x,ES11.4))") " elecbar_asym_p (x=0.999) = ", jll_nll + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, elecbar_asym_p, LL+NLL, alpha running:" + write (u, "(A)") + call elecbar_asym_p (x1, jll_nll, n_lep, ln0, order, running=.true.) + write (u, "(1x,A,6(1x,ES11.4))") " elecbar_asym_p (x=0.100) = ", jll_nll + call elecbar_asym_p (x2, jll_nll, n_lep, ln0, order, running=.true.) + write (u, "(1x,A,6(1x,ES11.4))") " elecbar_asym_p (x=0.500) = ", jll_nll + call elecbar_asym_p (x3, jll_nll, n_lep, ln0, order, running=.true.) + write (u, "(1x,A,6(1x,ES11.4))") " elecbar_asym_p (x=0.900) = ", jll_nll + call elecbar_asym_p (x4, jll_nll, n_lep, ln0, order, running=.true.) + write (u, "(1x,A,6(1x,ES11.4))") " elecbar_asym_p (x=0.999) = ", jll_nll + + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, photbar_asym_p, LL+NLL, alpha fixed:" + write (u, "(A)") + call photbar_asym_p (x1, jll_nll, n_lep, ln0, order, running=.false.) + write (u, "(1x,A,6(1x,ES11.4))") " photbar_asym_p (x=0.100) = ", jll_nll + call photbar_asym_p (x2, jll_nll, n_lep, ln0, order, running=.false.) + write (u, "(1x,A,6(1x,ES11.4))") " photbar_asym_p (x=0.500) = ", jll_nll + call photbar_asym_p (x3, jll_nll, n_lep, ln0, order, running=.false.) + write (u, "(1x,A,6(1x,ES11.4))") " photbar_asym_p (x=0.900) = ", jll_nll + call photbar_asym_p (x4, jll_nll, n_lep, ln0, order, running=.false.) + write (u, "(1x,A,6(1x,ES11.4))") " photbar_asym_p (x=0.999) = ", jll_nll + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, photbar_asym_p, LL+NLL, alpha running:" + write (u, "(A)") + call photbar_asym_p (x1, jll_nll, n_lep, ln0, order, running=.true.) + write (u, "(1x,A,6(1x,ES11.4))") " photbar_asym_p (x=0.100) = ", jll_nll + call photbar_asym_p (x2, jll_nll, n_lep, ln0, order, running=.true.) + write (u, "(1x,A,6(1x,ES11.4))") " photbar_asym_p (x=0.500) = ", jll_nll + call photbar_asym_p (x3, jll_nll, n_lep, ln0, order, running=.true.) + write (u, "(1x,A,6(1x,ES11.4))") " photbar_asym_p (x=0.900) = ", jll_nll + call photbar_asym_p (x4, jll_nll, n_lep, ln0, order, running=.true.) + write (u, "(1x,A,6(1x,ES11.4))") " photbar_asym_p (x=0.999) = ", jll_nll + + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, rechat_s, LL+NLL, alpha fixed:" + write (u, "(A)") + call rechat_singlet (x1, jll_nll, n_lep, ln0, order, running=.false.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_singlet (x=0.100) = ", jll_nll + call rechat_singlet (x2, jll_nll, n_lep, ln0, order, running=.false.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_singlet (x=0.500) = ", jll_nll + call rechat_singlet (x3, jll_nll, n_lep, ln0, order, running=.false.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_singlet (x=0.900) = ", jll_nll + call rechat_singlet (x4, jll_nll, n_lep, ln0, order, running=.false.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_singlet (x=0.999) = ", jll_nll + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, rechat_s, LL+NLL, alpha running:" + write (u, "(A)") + call rechat_singlet (x1, jll_nll, n_lep, ln0, order, running=.true.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_singlet (x=0.100) = ", jll_nll + call rechat_singlet (x2, jll_nll, n_lep, ln0, order, running=.true.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_singlet (x=0.500) = ", jll_nll + call rechat_singlet (x3, jll_nll, n_lep, ln0, order, running=.true.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_singlet (x=0.900) = ", jll_nll + call rechat_singlet (x4, jll_nll, n_lep, ln0, order, running=.true.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_singlet (x=0.999) = ", jll_nll + + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, rechat_ns, LL+NLL, alpha fixed:" + write (u, "(A)") + call rechat_nonsinglet (x1, jll_nll, n_lep, ln0, order, running=.false.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_nonsinglet (x=0.100) = ", jll_nll + call rechat_nonsinglet (x2, jll_nll, n_lep, ln0, order, running=.false.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_nonsinglet (x=0.500) = ", jll_nll + call rechat_nonsinglet (x3, jll_nll, n_lep, ln0, order, running=.false.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_nonsinglet (x=0.900) = ", jll_nll + call rechat_nonsinglet (x4, jll_nll, n_lep, ln0, order, running=.false.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_nonsinglet (x=0.999) = ", jll_nll + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, rechat_ns, LL+NLL, alpha running:" + write (u, "(A)") + call rechat_nonsinglet (x1, jll_nll, n_lep, ln0, order, running=.true.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_nonsinglet (x=0.100) = ", jll_nll + call rechat_nonsinglet (x2, jll_nll, n_lep, ln0, order, running=.true.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_nonsinglet (x=0.500) = ", jll_nll + call rechat_nonsinglet (x3, jll_nll, n_lep, ln0, order, running=.true.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_nonsinglet (x=0.900) = ", jll_nll + call rechat_nonsinglet (x4, jll_nll, n_lep, ln0, order, running=.true.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_nonsinglet (x=0.999) = ", jll_nll + + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, rechat_photon, LL+NLL, alpha fixed:" + write (u, "(A)") + call rechat_photon (x1, jll_nll, n_lep, ln0, order, running=.false.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_photon (x=0.100) = ", jll_nll + call rechat_photon (x2, jll_nll, n_lep, ln0, order, running=.false.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_photon (x=0.500) = ", jll_nll + call rechat_photon (x3, jll_nll, n_lep, ln0, order, running=.false.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_photon (x=0.900) = ", jll_nll + call rechat_photon (x4, jll_nll, n_lep, ln0, order, running=.false.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_photon (x=0.999) = ", jll_nll + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, rechat_photon, LL+NLL, alpha running:" + write (u, "(A)") + call rechat_photon (x1, jll_nll, n_lep, ln0, order, running=.true.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_photon (x=0.100) = ", jll_nll + call rechat_photon (x2, jll_nll, n_lep, ln0, order, running=.true.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_photon (x=0.500) = ", jll_nll + call rechat_photon (x3, jll_nll, n_lep, ln0, order, running=.true.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_photon (x=0.900) = ", jll_nll + call rechat_photon (x4, jll_nll, n_lep, ln0, order, running=.true.) + write (u, "(1x,A,6(1x,ES11.4))") " rechat_photon (x=0.999) = ", jll_nll + + write (u, "(A)") + write (u, "(A)") "* Test output end: electron_pdfs_2" + + end subroutine electron_pdfs_2 + +@ %def electron_pdfs_2 +@ +<>= + call test (electron_pdfs_3, "electron_pdfs_3", & + "Electron PDFs: auxiliary functions (3)", & + u, results) +<>= + public :: electron_pdfs_3 +<>= + subroutine electron_pdfs_3 (u) + integer, intent(in) :: u + type(qed_pdf_t) :: pdf + real(default) :: Q, alpha + real(default) :: x1, x2, x3, x4 + integer :: n_lep + Q = 10._default + x1 = 0.1_default + x2 = 0.5_default + x3 = 0.9_default + x4 = 0.999_default + alpha = ALPHA_QED_ME_REF + n_lep = 1 + + write (u, "(A)") "* Test output: electron_pdfs_3" + write (u, "(A)") "* Purpose: check analytic properties" + write (u, "(A)") + + write (u, "(A)") "* Auxiliary functions III:" + write (u, "(A)") + + write (u, "(A)") "* Q = 10 GeV, bar_asym, e+-, LL+NLL, alpha fixed:" + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 0, n_lep) + write (u, "(1x,A,F11.6)") " bar_asym (ELE,LL,x=0.100) = ", & + bar_asym (pdf, EPDF_ELE, x1, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " bar_asym (ELE,LL,x=0.500) = ", & + bar_asym (pdf, EPDF_ELE, x2, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " bar_asym (ELE,LL,x=0.900) = ", & + bar_asym (pdf, EPDF_ELE, x3, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " bar_asym (ELE,LL,x=0.999) = ", & + bar_asym (pdf, EPDF_ELE, x4, Q, alpha, running=.false.) + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, n_lep) + write (u, "(1x,A,F11.6)") " bar_asym (ELE,NLL,x=0.100) = ", & + bar_asym (pdf, EPDF_ELE, x1, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " bar_asym (ELE,NLL,x=0.500) = ", & + bar_asym (pdf, EPDF_ELE, x2, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " bar_asym (ELE,NLL,x=0.900) = ", & + bar_asym (pdf, EPDF_ELE, x3, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " bar_asym (ELE,NLL,x=0.999) = ", & + bar_asym (pdf, EPDF_ELE, x4, Q, alpha, running=.false.) + + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, bar_asym, e+-, LL+NLL, alpha running:" + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 0, n_lep) + call pdf%allocate_aqed (order = 0, n_f = 0, n_lep = 1, running = .true.) + write (u, "(1x,A,F11.6)") " bar_asym (ELE,LL,x=0.100) = ", & + bar_asym (pdf, EPDF_ELE, x1, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " bar_asym (ELE,LL,x=0.500) = ", & + bar_asym (pdf, EPDF_ELE, x2, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " bar_asym (ELE,LL,x=0.900) = ", & + bar_asym (pdf, EPDF_ELE, x3, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " bar_asym (ELE,LL,x=0.999) = ", & + bar_asym (pdf, EPDF_ELE, x4, Q, alpha, running=.true.) + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, n_lep) + call pdf%allocate_aqed (order = 1, n_f = 0, n_lep = 1, running = .true.) + write (u, "(1x,A,F11.6)") " bar_asym (ELE,NLL,x=0.100) = ", & + bar_asym (pdf, EPDF_ELE, x1, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " bar_asym (ELE,NLL,x=0.500) = ", & + bar_asym (pdf, EPDF_ELE, x2, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " bar_asym (ELE,NLL,x=0.900) = ", & + bar_asym (pdf, EPDF_ELE, x3, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " bar_asym (ELE,NLL,x=0.999) = ", & + bar_asym (pdf, EPDF_ELE, x4, Q, alpha, running=.true.) + + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, bar_asym, gam, LL+NLL, alpha fixed:" + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 0, n_lep) + write (u, "(1x,A,F11.6)") " bar_asym (GAM,LL,x=0.100) = ", & + bar_asym (pdf, EPDF_G, x1, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " bar_asym (GAM,LL,x=0.500) = ", & + bar_asym (pdf, EPDF_G, x2, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " bar_asym (GAM,LL,x=0.900) = ", & + bar_asym (pdf, EPDF_G, x3, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " bar_asym (GAM,LL,x=0.999) = ", & + bar_asym (pdf, EPDF_G, x4, Q, alpha, running=.false.) + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, n_lep) + write (u, "(1x,A,F11.6)") " bar_asym (GAM,NLL,x=0.100) = ", & + bar_asym (pdf, EPDF_G, x1, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " bar_asym (GAM,NLL,x=0.500) = ", & + bar_asym (pdf, EPDF_G, x2, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " bar_asym (GAM,NLL,x=0.900) = ", & + bar_asym (pdf, EPDF_G, x3, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " bar_asym (GAM,NLL,x=0.999) = ", & + bar_asym (pdf, EPDF_G, x4, Q, alpha, running=.false.) + + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, bar_asym, gam, LL+NLL, alpha running:" + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 0, n_lep) + call pdf%allocate_aqed (order = 0, n_f = 0, n_lep = 1, running = .true.) + write (u, "(1x,A,F11.6)") " bar_asym (GAM,LL,x=0.100) = ", & + bar_asym (pdf, EPDF_G, x1, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " bar_asym (GAM,LL,x=0.500) = ", & + bar_asym (pdf, EPDF_G, x2, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " bar_asym (GAM,LL,x=0.900) = ", & + bar_asym (pdf, EPDF_G, x3, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " bar_asym (GAM,LL,x=0.999) = ", & + bar_asym (pdf, EPDF_G, x4, Q, alpha, running=.true.) + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, n_lep) + call pdf%allocate_aqed (order = 1, n_f = 0, n_lep = 1, running = .true.) + write (u, "(1x,A,F11.6)") " bar_asym (GAM,NLL,x=0.100) = ", & + bar_asym (pdf, EPDF_G, x1, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " bar_asym (GAM,NLL,x=0.500) = ", & + bar_asym (pdf, EPDF_G, x2, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " bar_asym (GAM,NLL,x=0.900) = ", & + bar_asym (pdf, EPDF_G, x3, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " bar_asym (GAM,NLL,x=0.999) = ", & + bar_asym (pdf, EPDF_G, x4, Q, alpha, running=.true.) + + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, recbar, S, LL+NLL, alpha fixed:" + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 0, n_lep) + write (u, "(1x,A,F11.6)") " recbar (S,LL,x=0.100) = ", & + recbar (pdf, EPDF_S, x1, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " recbar (S,LL,x=0.500) = ", & + recbar (pdf, EPDF_S, x2, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " recbar (S,LL,x=0.900) = ", & + recbar (pdf, EPDF_S, x3, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " recbar (S,LL,x=0.999) = ", & + recbar (pdf, EPDF_S, x4, Q, alpha, running=.false.) + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, n_lep) + write (u, "(1x,A,F11.6)") " recbar (S,NLL,x=0.100) = ", & + recbar (pdf, EPDF_S, x1, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " recbar (S,NLL,x=0.500) = ", & + recbar (pdf, EPDF_S, x2, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " recbar (S,NLL,x=0.900) = ", & + recbar (pdf, EPDF_S, x3, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " recbar (S,NLL,x=0.999) = ", & + recbar (pdf, EPDF_S, x4, Q, alpha, running=.false.) + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, recbar, S, LL+NLL, alpha running:" + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 0, n_lep) + call pdf%allocate_aqed (order = 0, n_f = 0, n_lep = 1, running = .true.) + write (u, "(1x,A,F11.6)") " recbar (S,LL,x=0.100) = ", & + recbar (pdf, EPDF_S, x1, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " recbar (S,LL,x=0.500) = ", & + recbar (pdf, EPDF_S, x2, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " recbar (S,LL,x=0.900) = ", & + recbar (pdf, EPDF_S, x3, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " recbar (S,LL,x=0.999) = ", & + recbar (pdf, EPDF_S, x4, Q, alpha, running=.true.) + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, n_lep) + call pdf%allocate_aqed (order = 1, n_f = 0, n_lep = 1, running = .true.) + write (u, "(1x,A,F11.6)") " recbar (S,NLL,x=0.100) = ", & + recbar (pdf, EPDF_S, x1, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " recbar (S,NLL,x=0.500) = ", & + recbar (pdf, EPDF_S, x2, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " recbar (S,NLL,x=0.900) = ", & + recbar (pdf, EPDF_S, x3, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " recbar (S,NLL,x=0.999) = ", & + recbar (pdf, EPDF_S, x4, Q, alpha, running=.true.) + + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, recbar, NS, LL+NLL, alpha fixed:" + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 0, n_lep) + write (u, "(1x,A,F11.6)") " recbar (NS,LL,x=0.100) = ", & + recbar (pdf, EPDF_NS, x1, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " recbar (NS,LL,x=0.500) = ", & + recbar (pdf, EPDF_NS, x2, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " recbar (NS,LL,x=0.900) = ", & + recbar (pdf, EPDF_NS, x3, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " recbar (NS,LL,x=0.999) = ", & + recbar (pdf, EPDF_NS, x4, Q, alpha, running=.false.) + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, n_lep) + write (u, "(1x,A,F11.6)") " recbar (NS,NLL,x=0.100) = ", & + recbar (pdf, EPDF_NS, x1, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " recbar (NS,NLL,x=0.500) = ", & + recbar (pdf, EPDF_NS, x2, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " recbar (NS,NLL,x=0.900) = ", & + recbar (pdf, EPDF_NS, x3, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " recbar (NS,NLL,x=0.999) = ", & + recbar (pdf, EPDF_NS, x4, Q, alpha, running=.false.) + + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, recbar, NS, LL+NLL, alpha running:" + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 0, n_lep) + call pdf%allocate_aqed (order = 0, n_f = 0, n_lep = 1, running = .true.) + write (u, "(1x,A,F11.6)") " recbar (NS,LL,x=0.100) = ", & + recbar (pdf, EPDF_NS, x1, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " recbar (NS,LL,x=0.500) = ", & + recbar (pdf, EPDF_NS, x2, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " recbar (NS,LL,x=0.900) = ", & + recbar (pdf, EPDF_NS, x3, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " recbar (NS,LL,x=0.999) = ", & + recbar (pdf, EPDF_NS, x4, Q, alpha, running=.true.) + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, n_lep) + call pdf%allocate_aqed (order = 1, n_f = 0, n_lep = 1, running = .true.) + write (u, "(1x,A,F11.6)") " recbar (NS,NLL,x=0.100) = ", & + recbar (pdf, EPDF_NS, x1, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " recbar (NS,NLL,x=0.500) = ", & + recbar (pdf, EPDF_NS, x2, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " recbar (NS,NLL,x=0.900) = ", & + recbar (pdf, EPDF_NS, x3, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " recbar (NS,NLL,x=0.999) = ", & + recbar (pdf, EPDF_NS, x4, Q, alpha, running=.true.) + + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, recbar, GAM, LL+NLL, alpha fixed:" + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 0, n_lep) + write (u, "(1x,A,F11.6)") " recbar (GAM,LL,x=0.100) = ", & + recbar (pdf, EPDF_G, x1, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " recbar (GAM,LL,x=0.500) = ", & + recbar (pdf, EPDF_G, x2, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " recbar (GAM,LL,x=0.900) = ", & + recbar (pdf, EPDF_G, x3, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " recbar (GAM,LL,x=0.999) = ", & + recbar (pdf, EPDF_G, x4, Q, alpha, running=.false.) + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, n_lep) + write (u, "(1x,A,F11.6)") " recbar (GAM,NLL,x=0.100) = ", & + recbar (pdf, EPDF_G, x1, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " recbar (GAM,NLL,x=0.500) = ", & + recbar (pdf, EPDF_G, x2, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " recbar (GAM,NLL,x=0.900) = ", & + recbar (pdf, EPDF_G, x3, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " recbar (GAM,NLL,x=0.999) = ", & + recbar (pdf, EPDF_G, x4, Q, alpha, running=.false.) + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, recbar, GAM, LL+NLL, alpha running:" + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 0, n_lep) + call pdf%allocate_aqed (order = 0, n_f = 0, n_lep = 1, running = .true.) + write (u, "(1x,A,F11.6)") " recbar (GAM,LL,x=0.100) = ", & + recbar (pdf, EPDF_G, x1, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " recbar (GAM,LL,x=0.500) = ", & + recbar (pdf, EPDF_G, x2, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " recbar (GAM,LL,x=0.900) = ", & + recbar (pdf, EPDF_G, x3, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " recbar (GAM,LL,x=0.999) = ", & + recbar (pdf, EPDF_G, x4, Q, alpha, running=.true.) + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, n_lep) + call pdf%allocate_aqed (order = 1, n_f = 0, n_lep = 1, running = .true.) + write (u, "(1x,A,F11.6)") " recbar (GAM,NLL,x=0.100) = ", & + recbar (pdf, EPDF_G, x1, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " recbar (GAM,NLL,x=0.500) = ", & + recbar (pdf, EPDF_G, x2, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " recbar (GAM,NLL,x=0.900) = ", & + recbar (pdf, EPDF_G, x3, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " recbar (GAM,NLL,x=0.999) = ", & + recbar (pdf, EPDF_G, x4, Q, alpha, running=.true.) + + write (u, "(A)") + write (u, "(A)") "* Test output end: electron_pdfs_3" + + end subroutine electron_pdfs_3 + +@ %def electron_pdfs_3 +@ +<>= + call test (electron_pdfs_4, "electron_pdfs_4", & + "Electron PDFs: auxiliary functions (4)", & + u, results) +<>= + public :: electron_pdfs_4 +<>= + subroutine electron_pdfs_4 (u) + integer, intent(in) :: u + type(qed_pdf_t) :: pdf + real(default) :: Q, alpha + real(default) :: x1, x2, x3, x4 + integer :: n_lep + Q = 10._default + x1 = 0.1_default + x2 = 0.5_default + x3 = 0.9_default + x4 = 0.999_default + alpha = ALPHA_QED_ME_REF + n_lep = 1 + + write (u, "(A)") "* Test output: electron_pdfs_4" + write (u, "(A)") "* Purpose: check analytic properties" + write (u, "(A)") + + write (u, "(A)") "* Auxiliary functions IV:" + write (u, "(A)") + + write (u, "(A)") "* Q = 10 GeV, rechat, S, LL+NLL, alpha fixed:" + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 0, n_lep) + write (u, "(1x,A,F11.6)") " rechat (S,LL,x=0.100) = ", & + rechat (pdf, EPDF_S, x1, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " rechat (S,LL,x=0.500) = ", & + rechat (pdf, EPDF_S, x2, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " rechat (S,LL,x=0.900) = ", & + rechat (pdf, EPDF_S, x3, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " rechat (S,LL,x=0.999) = ", & + rechat (pdf, EPDF_S, x4, Q, alpha, running=.false.) + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, n_lep) + write (u, "(1x,A,F11.6)") " rechat (S,NLL,x=0.100) = ", & + rechat (pdf, EPDF_S, x1, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " rechat (S,NLL,x=0.500) = ", & + rechat (pdf, EPDF_S, x2, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " rechat (S,NLL,x=0.900) = ", & + rechat (pdf, EPDF_S, x3, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " rechat (S,NLL,x=0.999) = ", & + rechat (pdf, EPDF_S, x4, Q, alpha, running=.false.) + + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, rechat, S, LL+NLL, alpha running:" + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 0, n_lep) + call pdf%allocate_aqed (order = 0, n_f = 0, n_lep = 1, running = .true.) + write (u, "(1x,A,F11.6)") " rechat (S,LL,x=0.100) = ", & + rechat (pdf, EPDF_S, x1, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " rechat (S,LL,x=0.500) = ", & + rechat (pdf, EPDF_S, x2, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " rechat (S,LL,x=0.900) = ", & + rechat (pdf, EPDF_S, x3, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " rechat (S,LL,x=0.999) = ", & + rechat (pdf, EPDF_S, x4, Q, alpha, running=.true.) + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, n_lep) + call pdf%allocate_aqed (order = 1, n_f = 0, n_lep = 1, running = .true.) + write (u, "(1x,A,F11.6)") " rechat (S,NLL,x=0.100) = ", & + rechat (pdf, EPDF_S, x1, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " rechat (S,NLL,x=0.500) = ", & + rechat (pdf, EPDF_S, x2, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " rechat (S,NLL,x=0.900) = ", & + rechat (pdf, EPDF_S, x3, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " rechat (S,NLL,x=0.999) = ", & + rechat (pdf, EPDF_S, x4, Q, alpha, running=.true.) + + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, rechat, NS, LL+NLL, alpha fixed:" + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 0, n_lep) + write (u, "(1x,A,F11.6)") " rechat (NS,LL,x=0.100) = ", & + rechat (pdf, EPDF_NS, x1, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " rechat (NS,LL,x=0.500) = ", & + rechat (pdf, EPDF_NS, x2, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " rechat (NS,LL,x=0.900) = ", & + rechat (pdf, EPDF_NS, x3, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " rechat (NS,LL,x=0.999) = ", & + rechat (pdf, EPDF_NS, x4, Q, alpha, running=.false.) + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, n_lep) + write (u, "(1x,A,F11.6)") " rechat (NS,NLL,x=0.100) = ", & + rechat (pdf, EPDF_NS, x1, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " rechat (NS,NLL,x=0.500) = ", & + rechat (pdf, EPDF_NS, x2, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " rechat (NS,NLL,x=0.900) = ", & + rechat (pdf, EPDF_NS, x3, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " rechat (NS,NLL,x=0.999) = ", & + rechat (pdf, EPDF_NS, x4, Q, alpha, running=.false.) + + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, rechat, NS, LL+NLL, alpha running:" + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 0, n_lep) + call pdf%allocate_aqed (order = 0, n_f = 0, n_lep = 1, running = .true.) + write (u, "(1x,A,F11.6)") " rechat (NS,LL,x=0.100) = ", & + rechat (pdf, EPDF_NS, x1, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " rechat (NS,LL,x=0.500) = ", & + rechat (pdf, EPDF_NS, x2, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " rechat (NS,LL,x=0.900) = ", & + rechat (pdf, EPDF_NS, x3, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " rechat (NS,LL,x=0.999) = ", & + rechat (pdf, EPDF_NS, x4, Q, alpha, running=.true.) + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, n_lep) + call pdf%allocate_aqed (order = 1, n_f = 0, n_lep = 1, running = .true.) + write (u, "(1x,A,F11.6)") " rechat (NS,NLL,x=0.100) = ", & + rechat (pdf, EPDF_NS, x1, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " rechat (NS,NLL,x=0.500) = ", & + rechat (pdf, EPDF_NS, x2, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " rechat (NS,NLL,x=0.900) = ", & + rechat (pdf, EPDF_NS, x3, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " rechat (NS,NLL,x=0.999) = ", & + rechat (pdf, EPDF_NS, x4, Q, alpha, running=.true.) + + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, rechat, GAM, LL+NLL, alpha fixed:" + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 0, n_lep) + write (u, "(1x,A,F11.6)") " rechat (GAM,LL,x=0.100) = ", & + rechat (pdf, EPDF_G, x1, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " rechat (GAM,LL,x=0.500) = ", & + rechat (pdf, EPDF_G, x2, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " rechat (GAM,LL,x=0.900) = ", & + rechat (pdf, EPDF_G, x3, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " rechat (GAM,LL,x=0.999) = ", & + rechat (pdf, EPDF_G, x4, Q, alpha, running=.false.) + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, n_lep) + write (u, "(1x,A,F11.6)") " rechat (GAM,NLL,x=0.100) = ", & + rechat (pdf, EPDF_G, x1, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " rechat (GAM,NLL,x=0.500) = ", & + rechat (pdf, EPDF_G, x2, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " rechat (GAM,NLL,x=0.900) = ", & + rechat (pdf, EPDF_G, x3, Q, alpha, running=.false.) + write (u, "(1x,A,F11.6)") " rechat (GAM,NLL,x=0.999) = ", & + rechat (pdf, EPDF_G, x4, Q, alpha, running=.false.) + + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, rechat, GAM, LL+NLL, alpha running:" + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 0, n_lep) + call pdf%allocate_aqed (order = 0, n_f = 0, n_lep = 1, running = .true.) + write (u, "(1x,A,F11.6)") " rechat (GAM,LL,x=0.100) = ", & + rechat (pdf, EPDF_G, x1, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " rechat (GAM,LL,x=0.500) = ", & + rechat (pdf, EPDF_G, x2, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " rechat (GAM,LL,x=0.900) = ", & + rechat (pdf, EPDF_G, x3, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " rechat (GAM,LL,x=0.999) = ", & + rechat (pdf, EPDF_G, x4, Q, alpha, running=.true.) + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, n_lep) + call pdf%allocate_aqed (order = 1, n_f = 0, n_lep = 1, running = .true.) + write (u, "(1x,A,F11.6)") " rechat (GAM,NLL,x=0.100) = ", & + rechat (pdf, EPDF_G, x1, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " rechat (GAM,NLL,x=0.500) = ", & + rechat (pdf, EPDF_G, x2, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " rechat (GAM,NLL,x=0.900) = ", & + rechat (pdf, EPDF_G, x3, Q, alpha, running=.true.) + write (u, "(1x,A,F11.6)") " rechat (GAM,NLL,x=0.999) = ", & + rechat (pdf, EPDF_G, x4, Q, alpha, running=.true.) + + write (u, "(A)") + write (u, "(A)") "* Test output end: electron_pdfs_4" + + end subroutine electron_pdfs_4 + +@ %def electron_pdfs_4 +@ +<>= + call test (electron_pdfs_5, "electron_pdfs_5", & + "Electron PDFs: auxiliary functions (5)", & + u, results) +<>= + public :: electron_pdfs_5 +<>= + subroutine electron_pdfs_5 (u) + integer, intent(in) :: u + type(qed_pdf_t) :: pdf + real(default) :: Q, alpha + real(default) :: x1, x2, x3, x4 + integer :: n_lep + Q = 10._default + x1 = 0.1_default + x2 = 0.5_default + x3 = 0.9_default + x4 = 0.999_default + alpha = ALPHA_QED_ME_REF + n_lep = 1 + + write (u, "(A)") "* Test output: electron_pdfs_5" + write (u, "(A)") "* Purpose: check analytic properties" + write (u, "(A)") + + write (u, "(A)") "* Auxiliary functions V:" + write (u, "(A)") + + write (u, "(A)") "* Integrals over endpoint_func_NS, interval [0,1]:" + write (u, "(A)") + write (u, "(1x,A,F11.6)") " endpoint_func_NS (0.100) = ", & + endpoint_func_NS (x1) + write (u, "(1x,A,F11.6)") " endpoint_func_NS (0.500) = ", & + endpoint_func_NS (x2) + write (u, "(1x,A,F11.6)") " endpoint_func_NS (0.900) = ", & + endpoint_func_NS (x3) + write (u, "(1x,A,F11.6)") " endpoint_func_NS (0.999) = ", & + endpoint_func_NS (x4) + + write (u, "(A)") + write (u, "(A)") "* Integrals over endpoint_func_S, interval [0,1]:" + write (u, "(A)") + write (u, "(1x,A,F11.6)") " endpoint_func_S (0.100) = ", & + endpoint_func_S (x1, n_lep) + write (u, "(1x,A,F11.6)") " endpoint_func_S (0.500) = ", & + endpoint_func_S (x2, n_lep) + write (u, "(1x,A,F11.6)") " endpoint_func_S (0.900) = ", & + endpoint_func_S (x3, n_lep) + write (u, "(1x,A,F11.6)") " endpoint_func_S (0.999) = ", & + endpoint_func_S (x4, n_lep) + + write (u, "(A)") + write (u, "(A)") "* Integrals over endpoint_func_GAM, interval [0,1]:" + write (u, "(A)") + write (u, "(1x,A,F11.6)") " endpoint_func_GAM (0.100) = ", & + endpoint_func_GAM (x1) + write (u, "(1x,A,F11.6)") " endpoint_func_GAM (0.500) = ", & + endpoint_func_GAM (x2) + write (u, "(1x,A,F11.6)") " endpoint_func_GAM (0.900) = ", & + endpoint_func_GAM (x3) + write (u, "(1x,A,F11.6)") " endpoint_func_GAM (0.999) = ", & + endpoint_func_GAM (x4) + + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, recnum, alpha fixed:" + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, n_lep) + write (u, "(1x,A,ES11.4)") " recnum (S, 0.100) = ", & + rec_num (pdf, EPDF_S, x1, Q, alpha, .false.) + write (u, "(1x,A,ES11.4)") " recnum (S, 0.500) = ", & + rec_num (pdf, EPDF_S, x2, Q, alpha, .false.) + write (u, "(1x,A,ES11.4)") " recnum (S, 0.900) = ", & + rec_num (pdf, EPDF_S, x3, Q, alpha, .false.) + write (u, "(1x,A,ES11.4)") " recnum (S, 0.999) = ", & + rec_num (pdf, EPDF_S, x4, Q, alpha, .false.) + write (u, "(1x,A,ES11.4)") " recnum (NS, 0.100) = ", & + rec_num (pdf, EPDF_NS, x1, Q, alpha, .false.) + write (u, "(1x,A,ES11.4)") " recnum (NS, 0.500) = ", & + rec_num (pdf, EPDF_NS, x2, Q, alpha, .false.) + write (u, "(1x,A,ES11.4)") " recnum (NS, 0.900) = ", & + rec_num (pdf, EPDF_NS, x3, Q, alpha, .false.) + write (u, "(1x,A,ES11.4)") " recnum (NS, 0.999) = ", & + rec_num (pdf, EPDF_NS, x4, Q, alpha, .false.) + write (u, "(1x,A,ES11.4)") " recnum (GAM, 0.100) = ", & + rec_num (pdf, EPDF_G, x1, Q, alpha, .false.) + write (u, "(1x,A,ES11.4)") " recnum (GAM, 0.500) = ", & + rec_num (pdf, EPDF_G, x2, Q, alpha, .false.) + write (u, "(1x,A,ES11.4)") " recnum (GAM, 0.900) = ", & + rec_num (pdf, EPDF_G, x3, Q, alpha, .false.) + write (u, "(1x,A,ES11.4)") " recnum (GAM, 0.999) = ", & + rec_num (pdf, EPDF_G, x4, Q, alpha, .false.) + + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, recnum, alpha running:" + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, n_lep) + call pdf%allocate_aqed (order = 1, n_f = 0, n_lep = 1, running = .true.) + write (u, "(1x,A,ES11.4)") " recnum (S, 0.100) = ", & + rec_num (pdf, EPDF_S, x1, Q, alpha, .true.) + write (u, "(1x,A,ES11.4)") " recnum (S, 0.500) = ", & + rec_num (pdf, EPDF_S, x2, Q, alpha, .true.) + write (u, "(1x,A,ES11.4)") " recnum (S, 0.900) = ", & + rec_num (pdf, EPDF_S, x3, Q, alpha, .true.) + write (u, "(1x,A,ES11.4)") " recnum (S, 0.999) = ", & + rec_num (pdf, EPDF_S, x4, Q, alpha, .true.) + write (u, "(1x,A,ES11.4)") " recnum (NS, 0.100) = ", & + rec_num (pdf, EPDF_NS, x1, Q, alpha, .true.) + write (u, "(1x,A,ES11.4)") " recnum (NS, 0.500) = ", & + rec_num (pdf, EPDF_NS, x2, Q, alpha, .true.) + write (u, "(1x,A,ES11.4)") " recnum (NS, 0.900) = ", & + rec_num (pdf, EPDF_NS, x3, Q, alpha, .true.) + write (u, "(1x,A,ES11.4)") " recnum (NS, 0.999) = ", & + rec_num (pdf, EPDF_NS, x4, Q, alpha, .true.) + write (u, "(1x,A,ES11.4)") " recnum (GAM, 0.100) = ", & + rec_num (pdf, EPDF_G, x1, Q, alpha, .true.) + write (u, "(1x,A,ES11.4)") " recnum (GAM, 0.500) = ", & + rec_num (pdf, EPDF_G, x2, Q, alpha, .true.) + write (u, "(1x,A,ES11.4)") " recnum (GAM, 0.900) = ", & + rec_num (pdf, EPDF_G, x3, Q, alpha, .true.) + write (u, "(1x,A,ES11.4)") " recnum (GAM, 0.999) = ", & + rec_num (pdf, EPDF_G, x4, Q, alpha, .true.) + + write (u, "(A)") + write (u, "(A)") "* Test output end: electron_pdfs_5" + + end subroutine electron_pdfs_5 + +@ %def electron_pdfs_5 +@ +<>= + call test (electron_pdfs_6, "electron_pdfs_6", & + "Electron PDFs: full electron PDFs", & + u, results) +<>= + public :: electron_pdfs_6 +<>= + subroutine electron_pdfs_6 (u) + integer, intent(in) :: u + type(qed_pdf_t) :: pdf + real(default) :: Q, alpha + real(default), dimension(12) :: x + integer :: n_lep + Q = 10._default + x( 1) = 0.1_default + x( 2) = 0.2_default + x( 3) = 0.3_default + x( 4) = 0.4_default + x( 5) = 0.5_default + x( 6) = 0.6_default + x( 7) = 0.7_default + x( 8) = 0.8_default + x( 9) = 0.9_default + x(10) = 0.95_default + x(11) = 0.99_default + x(12) = 0.999_default + alpha = ALPHA_QED_ME_REF + n_lep = 1 + + write (u, "(A)") "* Test output: electron_pdfs_6" + write (u, "(A)") "* Purpose: full electron PDFs" + write (u, "(A)") + + write (u, "(A)") "* Full NLL electron PDFs:" + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, NLL, alpha fixed:" + write (u, "(A)") + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, n_lep) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.100, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(1), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_G, x(1), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_NS, x(1), Q, alpha, .false., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.200, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(2), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_G, x(2), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_NS, x(2), Q, alpha, .false., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.300, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(3), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_G, x(3), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_NS, x(3), Q, alpha, .false., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.400, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(4), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_G, x(4), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_NS, x(4), Q, alpha, .false., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.500, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(5), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_G, x(5), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_NS, x(5), Q, alpha, .false., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.600, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(6), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_G, x(6), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_NS, x(6), Q, alpha, .false., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.700, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(7), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_G, x(7), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_NS, x(7), Q, alpha, .false., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.800, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(8), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_G, x(8), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_NS, x(8), Q, alpha, .false., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.900, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(9), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_G, x(9), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_NS, x(9), Q, alpha, .false., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.950, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(10), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_G, x(10), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_NS, x(10), Q, alpha, .false., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.990, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(11), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_G, x(11), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_NS, x(11), Q, alpha, .false., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.999, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(12), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_G, x(12), Q, alpha, .false., .true.), & + elec_pdf (pdf, EPDF_NS, x(12), Q, alpha, .false., .true.) + write (u, "(A)") + write (u, "(A)") "* Q = 10 GeV, NLL, alpha running:" + write (u, "(A)") + call pdf%init (ME_REF, ALPHA_QED_ME_REF, -1._default, & + 3000._default, 3, 1, n_lep) + call pdf%allocate_aqed (order = 1, n_f = 0, n_lep = 1, running = .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.100, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(1), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_G, x(1), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_NS, x(1), Q, alpha, .true., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.200, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(2), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_G, x(2), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_NS, x(2), Q, alpha, .true., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.300, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(3), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_G, x(3), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_NS, x(3), Q, alpha, .true., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.400, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(4), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_G, x(4), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_NS, x(4), Q, alpha, .true., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.500, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(5), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_G, x(5), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_NS, x(5), Q, alpha, .true., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.600, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(6), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_G, x(6), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_NS, x(6), Q, alpha, .true., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.700, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(7), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_G, x(7), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_NS, x(7), Q, alpha, .true., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.800, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(8), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_G, x(8), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_NS, x(8), Q, alpha, .true., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.900, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(9), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_G, x(9), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_NS, x(9), Q, alpha, .true., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.950, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(10), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_G, x(10), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_NS, x(10), Q, alpha, .true., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.990, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(11), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_G, x(11), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_NS, x(11), Q, alpha, .true., .true.) + write (u, "(1x,A,3(1x,F11.6))") " ePDF (x = 0.999, S/GAM/NS) = ", & + elec_pdf (pdf, EPDF_S, x(12), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_G, x(12), Q, alpha, .true., .true.), & + elec_pdf (pdf, EPDF_NS, x(12), Q, alpha, .true., .true.) + write (u, "(A)") + write (u, "(A)") "* Check singlet-nonsinglet linear combination" + write (u, "(A)") + write (u, "(1x,A,F11.6)") " ePDF (x = 0.950, e- - [S + NS]/2) = ", & + elec_pdf (pdf, EPDF_ELE, x(10), Q, alpha, .true., .true.) - & + (elec_pdf (pdf, EPDF_S, x(10), Q, alpha, .true., .true.) + & + elec_pdf (pdf, EPDF_NS, x(10), Q, alpha, .true., .true.))/two + write (u, "(1x,A,F11.6)") " ePDF (x = 0.950, e+ - [S - NS]/2) = ", & + elec_pdf (pdf, EPDF_POS, x(10), Q, alpha, .true., .true.) - & + (elec_pdf (pdf, EPDF_S, x(10), Q, alpha, .true., .true.) - & + elec_pdf (pdf, EPDF_NS, x(10), Q, alpha, .true., .true.))/two + + write (u, "(A)") + write (u, "(A)") "* Test output end: electron_pdfs_6" + + end subroutine electron_pdfs_6 Index: trunk/src/basics/constants.f90 =================================================================== --- trunk/src/basics/constants.f90 (revision 8815) +++ trunk/src/basics/constants.f90 (revision 8816) @@ -1,71 +1,72 @@ ! WHIZARD <> <> ! ! Copyright (C) 1999-2022 by ! Wolfgang Kilian ! Thorsten Ohl ! Juergen Reuter ! Christian Speckner ! with contributions by Sebastian Schmidt, Daniel Wiesler, Felix Braam ! ! WHIZARD is free software; you can redistribute it and/or modify it ! under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 2, or (at your option) ! any later version. ! ! WHIZARD is distributed in the hope that it will be useful, but ! WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this program; if not, write to the Free Software ! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!! Numeric constants, no reference to physics in particular module constants use kinds, only: default implicit none private complex(default), parameter, public :: & imago = (0._default, 1._default) real(default), parameter, public :: & zero = 0.0_default, & one = 1.0_default, & two = 2.0_default, & three = 3.0_default, & four = 4.0_default, & five = 5.0_default real(default), parameter, public :: & sqrt2 = sqrt (two) real(default), parameter, public :: & - pi = 3.1415926535897932384626433832795028841972_default + pi = 3.1415926535897932384626433832795028841972_default, & + pi2 = pi**2 real(default), parameter, public :: & twopi = 2*pi, & twopi2 = twopi**2, & twopi3 = twopi**3, & twopi4 = twopi**4, & twopi5 = twopi**5, & twopi6 = twopi**6 real(default), parameter, public :: & degree = pi/180 !!! On double precision, these are roughly !!! 2.22E-016 2.22E-013 2.22E-010 2.22E-007 real(default), parameter, public :: & eps0 = epsilon (zero), & tiny_13 = 1E3_default * epsilon (zero), & tiny_10 = 1E6_default * epsilon (zero), & tiny_07 = 1E9_default * epsilon (zero) end module constants Index: trunk/src/variables/variables.nw =================================================================== --- trunk/src/variables/variables.nw (revision 8815) +++ trunk/src/variables/variables.nw (revision 8816) @@ -1,7741 +1,7755 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: variables for processes %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Variables for Processes} \includemodulegraph{variables} This part introduces variables as user-controlled objects that influence the behavior of objects and calculations. Variables contain objects of intrinsic type or of a type as introced above. \begin{description} \item[variables] Store values of various kind, used by expressions and accessed by the command interface. This provides an implementation of the [[vars_t]] abstract type. \item[observables] Concrete implementation of observables (functions in the variable tree), applicable for \whizard. abstract type. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Variables: Implementation} The user interface deals with variables that are handled similarly to full-flegded programming languages. The system will add a lot of predefined variables (model parameters, flags, etc.) that are accessible to the user by the same methods. Variables can be of various type: logical (boolean/flag), integer, real (default precision), subevents (used in cut expressions), arrays of PDG codes (aliases for particles), strings. Furthermore, in cut expressions we have unary and binary observables, which are used like real parameters but behave like functions. <<[[variables.f90]]>>= <> module variables <> <> use numeric_utils, only: pacify use os_interface, only: paths_t use pdg_arrays use subevents use var_base <> <> <> <> <> interface <> end interface end module variables @ %def variables @ <<[[variables_sub.f90]]>>= <> submodule (variables) variables_s use io_units use format_utils, only: pac_fmt use format_defs, only: FMT_12, FMT_19 use constants, only: eps0 use physics_defs, only: LAMBDA_QCD_REF use system_dependencies use diagnostics use fastjet !NODEP! implicit none contains <> end submodule variables_s @ %def variables_s @ \subsection{Variable list entries} Variable (and constant) values can be of one of the following types: <>= integer, parameter, public :: V_NONE = 0, V_LOG = 1, V_INT = 2, V_REAL = 3 integer, parameter, public :: V_CMPLX = 4, V_SEV = 5, V_PDG = 6, V_STR = 7 integer, parameter, public :: V_OBS1_INT = 11, V_OBS2_INT = 12 integer, parameter, public :: V_OBS1_REAL = 21, V_OBS2_REAL = 22 integer, parameter, public :: V_OBSEV_INT = 13, V_OBSEV_REAL = 23 integer, parameter, public :: V_UOBS1_INT = 31, V_UOBS2_INT = 32 integer, parameter, public :: V_UOBS1_REAL = 41, V_UOBS2_REAL = 42 @ %def V_NONE V_LOG V_INT V_REAL V_CMPLX V_PRT V_SEV V_PDG V_OBS1_INT @ %def V_OBS2_INT V_OBSEV_INT V_OBS1_REAL V_OBS2_REAL V_OBSEV_REAL @ %def V_UOBS1_INT V_UOBS2_INT V_UOBS1_REAL V_UOBS2_REAL @ \subsubsection{The type} This is an entry in the variable list. It can be of any type; in each case only one value is allocated. It may be physically allocated upon creation, in which case [[is_allocated]] is true, or it may contain just a pointer to a value somewhere else, in which case [[is_allocated]] is false. The flag [[is_defined]] is set when the variable is given a value, even the undefined value. (Therefore it is distinct from [[is_known]].) This matters for variable declaration in the SINDARIN language. The variable is set up in the compilation step and initially marked as defined, but after compilation all variables are set undefined. Each variable becomes defined when it is explicitly set. The difference matters in loops. [[is_locked]] means that it cannot be given a value using the interface routines [[var_list_set_XXX]] below. It can only be initialized, or change automatically due to a side effect. [[is_copy]] means that this is a local copy of a global variable. The copy has a pointer to the original, which can be used to restore a previous value. [[is_intrinsic]] means that this variable is defined by the program, not by the user. Intrinsic variables cannot be (re)declared, but their values can be reset unless they are locked. [[is_user_var]] means that the variable has been declared by the user. It could be a new variable, or a local copy of an intrinsic variable. The flag [[is_known]] is a pointer which parallels the use of the value pointer. For pointer variables, it is set if the value should point to a known value. For ordinary variables, it should be true. The value is implemented as a set of alternative type-specific pointers. This emulates polymorphism, and it allows for actual pointer variables. Observable-type variables have function pointers as values, so they behave like macros. The functions make use of the particle objects accessible via the pointers [[prt1]] and [[prt2]]. Finally, the [[next]] pointer indicates that we are making lists of variables. A more efficient implementation might switch to hashes or similar; the current implementation has $O(N)$ lookup. <>= type :: var_entry_t private integer :: type = V_NONE type(string_t) :: name logical :: is_allocated = .false. logical :: is_defined = .false. logical :: is_locked = .false. logical :: is_intrinsic = .false. logical :: is_user_var = .false. logical, pointer :: is_known => null () logical, pointer :: lval => null () integer, pointer :: ival => null () real(default), pointer :: rval => null () complex(default), pointer :: cval => null () type(subevt_t), pointer :: pval => null () type(pdg_array_t), pointer :: aval => null () type(string_t), pointer :: sval => null () procedure(obs_unary_int), nopass, pointer :: obs1_int => null () procedure(obs_unary_real), nopass, pointer :: obs1_real => null () procedure(obs_binary_int), nopass, pointer :: obs2_int => null () procedure(obs_binary_real), nopass, pointer :: obs2_real => null () procedure(obs_sev_int), nopass, pointer :: obsev_int => null () procedure(obs_sev_real), nopass, pointer :: obsev_real => null () type(prt_t), pointer :: prt1 => null () type(prt_t), pointer :: prt2 => null () type(var_entry_t), pointer :: next => null () type(var_entry_t), pointer :: previous => null () type(string_t) :: description end type var_entry_t @ %def var_entry_t @ \subsubsection{Interfaces for the observable functions} <>= public :: obs_unary_int public :: obs_unary_real public :: obs_binary_int public :: obs_binary_real public :: obs_sev_int public :: obs_sev_real <>= abstract interface function obs_unary_int (prt1) result (ival) import integer :: ival type(prt_t), intent(in) :: prt1 end function obs_unary_int end interface abstract interface function obs_unary_real (prt1) result (rval) import real(default) :: rval type(prt_t), intent(in) :: prt1 end function obs_unary_real end interface abstract interface function obs_binary_int (prt1, prt2) result (ival) import integer :: ival type(prt_t), intent(in) :: prt1, prt2 end function obs_binary_int end interface abstract interface function obs_binary_real (prt1, prt2) result (rval) import real(default) :: rval type(prt_t), intent(in) :: prt1, prt2 end function obs_binary_real end interface abstract interface function obs_sev_int (sev) result (ival) import integer :: ival type(subevt_t), intent(in) :: sev end function obs_sev_int end interface abstract interface function obs_sev_real (sev) result (rval) import real(default) :: rval type(subevt_t), intent(in) :: sev end function obs_sev_real end interface @ %def obs_unary_int obs_unary_real @ %def obs_binary_int obs_binary_real @ %def obs_sev_int obs_sev_real @ \subsubsection{Initialization} Initialize an entry, optionally with a physical value. We also allocate the [[is_known]] flag and set it if the value is set. <>= subroutine var_entry_init_log (var, name, lval, intrinsic, user) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name logical, intent(in), optional :: lval logical, intent(in), optional :: intrinsic, user var%name = name var%type = V_LOG allocate (var%lval, var%is_known) if (present (lval)) then var%lval = lval var%is_defined = .true. var%is_known = .true. else var%is_known = .false. end if if (present (intrinsic)) var%is_intrinsic = intrinsic if (present (user)) var%is_user_var = user var%is_allocated = .true. end subroutine var_entry_init_log subroutine var_entry_init_int (var, name, ival, intrinsic, user) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name integer, intent(in), optional :: ival logical, intent(in), optional :: intrinsic, user var%name = name var%type = V_INT allocate (var%ival, var%is_known) if (present (ival)) then var%ival = ival var%is_defined = .true. var%is_known = .true. else var%is_known = .false. end if if (present (intrinsic)) var%is_intrinsic = intrinsic if (present (user)) var%is_user_var = user var%is_allocated = .true. end subroutine var_entry_init_int subroutine var_entry_init_real (var, name, rval, intrinsic, user) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name real(default), intent(in), optional :: rval logical, intent(in), optional :: intrinsic, user var%name = name var%type = V_REAL allocate (var%rval, var%is_known) if (present (rval)) then var%rval = rval var%is_defined = .true. var%is_known = .true. else var%is_known = .false. end if if (present (intrinsic)) var%is_intrinsic = intrinsic if (present (user)) var%is_user_var = user var%is_allocated = .true. end subroutine var_entry_init_real subroutine var_entry_init_cmplx (var, name, cval, intrinsic, user) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name complex(default), intent(in), optional :: cval logical, intent(in), optional :: intrinsic, user var%name = name var%type = V_CMPLX allocate (var%cval, var%is_known) if (present (cval)) then var%cval = cval var%is_defined = .true. var%is_known = .true. else var%is_known = .false. end if if (present (intrinsic)) var%is_intrinsic = intrinsic if (present (user)) var%is_user_var = user var%is_allocated = .true. end subroutine var_entry_init_cmplx subroutine var_entry_init_subevt (var, name, pval, intrinsic, user) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name type(subevt_t), intent(in), optional :: pval logical, intent(in), optional :: intrinsic, user var%name = name var%type = V_SEV allocate (var%pval, var%is_known) if (present (pval)) then var%pval = pval var%is_defined = .true. var%is_known = .true. else var%is_known = .false. end if if (present (intrinsic)) var%is_intrinsic = intrinsic if (present (user)) var%is_user_var = user var%is_allocated = .true. end subroutine var_entry_init_subevt subroutine var_entry_init_pdg_array (var, name, aval, intrinsic, user) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name type(pdg_array_t), intent(in), optional :: aval logical, intent(in), optional :: intrinsic, user var%name = name var%type = V_PDG allocate (var%aval, var%is_known) if (present (aval)) then var%aval = aval var%is_defined = .true. var%is_known = .true. else var%is_known = .false. end if if (present (intrinsic)) var%is_intrinsic = intrinsic if (present (user)) var%is_user_var = user var%is_allocated = .true. end subroutine var_entry_init_pdg_array subroutine var_entry_init_string (var, name, sval, intrinsic, user) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name type(string_t), intent(in), optional :: sval logical, intent(in), optional :: intrinsic, user var%name = name var%type = V_STR allocate (var%sval, var%is_known) if (present (sval)) then var%sval = sval var%is_defined = .true. var%is_known = .true. else var%is_known = .false. end if if (present (intrinsic)) var%is_intrinsic = intrinsic if (present (user)) var%is_user_var = user var%is_allocated = .true. end subroutine var_entry_init_string @ %def var_entry_init_log @ %def var_entry_init_int @ %def var_entry_init_real @ %def var_entry_init_cmplx @ %def var_entry_init_subevt @ %def var_entry_init_pdg_array @ %def var_entry_init_string @ Initialize an entry with a pointer to the value and, for numeric/logical values, a pointer to the [[is_known]] flag. <>= subroutine var_entry_init_log_ptr (var, name, lval, is_known, intrinsic) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name logical, intent(in), target :: lval logical, intent(in), target :: is_known logical, intent(in), optional :: intrinsic var%name = name var%type = V_LOG var%lval => lval var%is_known => is_known if (present (intrinsic)) var%is_intrinsic = intrinsic var%is_defined = .true. end subroutine var_entry_init_log_ptr subroutine var_entry_init_int_ptr (var, name, ival, is_known, intrinsic) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name integer, intent(in), target :: ival logical, intent(in), target :: is_known logical, intent(in), optional :: intrinsic var%name = name var%type = V_INT var%ival => ival var%is_known => is_known if (present (intrinsic)) var%is_intrinsic = intrinsic var%is_defined = .true. end subroutine var_entry_init_int_ptr subroutine var_entry_init_real_ptr (var, name, rval, is_known, intrinsic) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name real(default), intent(in), target :: rval logical, intent(in), target :: is_known logical, intent(in), optional :: intrinsic var%name = name var%type = V_REAL var%rval => rval var%is_known => is_known if (present (intrinsic)) var%is_intrinsic = intrinsic var%is_defined = .true. end subroutine var_entry_init_real_ptr subroutine var_entry_init_cmplx_ptr (var, name, cval, is_known, intrinsic) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name complex(default), intent(in), target :: cval logical, intent(in), target :: is_known logical, intent(in), optional :: intrinsic var%name = name var%type = V_CMPLX var%cval => cval var%is_known => is_known if (present (intrinsic)) var%is_intrinsic = intrinsic var%is_defined = .true. end subroutine var_entry_init_cmplx_ptr subroutine var_entry_init_pdg_array_ptr (var, name, aval, is_known, intrinsic) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name type(pdg_array_t), intent(in), target :: aval logical, intent(in), target :: is_known logical, intent(in), optional :: intrinsic var%name = name var%type = V_PDG var%aval => aval var%is_known => is_known if (present (intrinsic)) var%is_intrinsic = intrinsic var%is_defined = .true. end subroutine var_entry_init_pdg_array_ptr subroutine var_entry_init_subevt_ptr (var, name, pval, is_known, intrinsic) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name type(subevt_t), intent(in), target :: pval logical, intent(in), target :: is_known logical, intent(in), optional :: intrinsic var%name = name var%type = V_SEV var%pval => pval var%is_known => is_known if (present (intrinsic)) var%is_intrinsic = intrinsic var%is_defined = .true. end subroutine var_entry_init_subevt_ptr subroutine var_entry_init_string_ptr (var, name, sval, is_known, intrinsic) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name type(string_t), intent(in), target :: sval logical, intent(in), target :: is_known logical, intent(in), optional :: intrinsic var%name = name var%type = V_STR var%sval => sval var%is_known => is_known if (present (intrinsic)) var%is_intrinsic = intrinsic var%is_defined = .true. end subroutine var_entry_init_string_ptr @ %def var_entry_init_log_ptr @ %def var_entry_init_int_ptr @ %def var_entry_init_real_ptr @ %def var_entry_init_cmplx_ptr @ %def var_entry_init_pdg_array_ptr @ %def var_entry_init_subevt_ptr @ %def var_entry_init_string_ptr @ Initialize an entry with an observable. The procedure pointer is not yet set. <>= subroutine var_entry_init_obs (var, name, type, prt1, prt2) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name integer, intent(in) :: type type(prt_t), intent(in), target :: prt1 type(prt_t), intent(in), optional, target :: prt2 var%type = type var%name = name var%prt1 => prt1 if (present (prt2)) var%prt2 => prt2 var%is_intrinsic = .true. var%is_defined = .true. end subroutine var_entry_init_obs subroutine var_entry_init_obs_sev (var, name, type, pval) type(var_entry_t), intent(out) :: var type(string_t), intent(in) :: name integer, intent(in) :: type type(subevt_t), intent(in), target :: pval var%type = type var%name = name var%pval => pval var%is_intrinsic = .true. var%is_defined = .true. end subroutine var_entry_init_obs_sev @ %def var_entry_init_obs var_entry_init_obs_sev @ Mark an entry as undefined it it is a user-defined variable object, so force re-initialization. <>= subroutine var_entry_undefine (var) type(var_entry_t), intent(inout) :: var var%is_defined = .not. var%is_user_var var%is_known = var%is_defined .and. var%is_known end subroutine var_entry_undefine @ %def var_entry_undefine @ Clear an entry: mark it as unknown. <>= subroutine var_entry_clear (var) type(var_entry_t), intent(inout) :: var var%is_known = .false. end subroutine var_entry_clear @ %def var_entry_clear @ Lock an entry: forbid resetting the entry after initialization. <>= subroutine var_entry_lock (var, locked) type(var_entry_t), intent(inout) :: var logical, intent(in), optional :: locked if (present (locked)) then var%is_locked = locked else var%is_locked = .true. end if end subroutine var_entry_lock @ %def var_entry_lock @ \subsubsection{Finalizer} <>= subroutine var_entry_final (var) type(var_entry_t), intent(inout) :: var if (var%is_allocated) then select case (var%type) case (V_LOG); deallocate (var%lval) case (V_INT); deallocate (var%ival) case (V_REAL);deallocate (var%rval) case (V_CMPLX);deallocate (var%cval) case (V_SEV); deallocate (var%pval) case (V_PDG); deallocate (var%aval) case (V_STR); deallocate (var%sval) end select deallocate (var%is_known) var%is_allocated = .false. var%is_defined = .false. end if end subroutine var_entry_final @ %def var_entry_final @ \subsubsection{Output} <>= recursive subroutine var_entry_write (var, unit, model_name, & intrinsic, pacified, descriptions, ascii_output) type(var_entry_t), intent(in) :: var integer, intent(in), optional :: unit type(string_t), intent(in), optional :: model_name logical, intent(in), optional :: intrinsic logical, intent(in), optional :: pacified logical, intent(in), optional :: descriptions logical, intent(in), optional :: ascii_output type(string_t) :: col_string logical :: show_desc, ao integer :: u u = given_output_unit (unit); if (u < 0) return show_desc = .false.; if (present (descriptions)) show_desc = descriptions ao = .false.; if (present (ascii_output)) ao = ascii_output if (show_desc) then if (ao) then col_string = create_col_string (COL_BLUE) if (var%is_locked) then write (u, "(A)", advance="no") char (achar(27) // col_string) // & char (var%name) // achar(27) // "[0m" //" fixed-value=" else write (u, "(A)", advance="no") char (achar(27) // col_string) // & char (var%name) // achar(27) // "[0m" //" default=" end if col_string = create_col_string (COL_RED) write (u, "(A)", advance="no") char (achar(27) // col_string) call var_write_val (var, u, "no", pacified=.true.) write (u, "(A)") achar(27) // "[0m" write (u, "(A)") char (var%description) return else write (u, "(A)") "\item" write (u, "(A)", advance="no") "\ttt{" // char ( & replace (replace (var%name, "_", "\_", every=.true.), "$", "\$" )) // & "} " if (var%is_known) then if (var%is_locked) then write (u, "(A)", advance="no") "\qquad (fixed value: \ttt{" else write (u, "(A)", advance="no") "\qquad (default: \ttt{" end if call var_write_val (var, u, "no", pacified=.true., escape_tex=.true.) write (u, "(A)", advance="no") "})" end if write (u, "(A)") " \newline" write (u, "(A)") char (var%description) write (u, "(A)") "%%%%%" return end if end if if (present (intrinsic)) then if (var%is_intrinsic .neqv. intrinsic) return end if if (.not. var%is_defined) then write (u, "(A,1x)", advance="no") "[undefined]" end if if (.not. var%is_intrinsic) then write (u, "(A,1x)", advance="no") "[user variable]" end if if (present (model_name)) then write (u, "(A,A)", advance="no") char(model_name), "." end if write (u, "(A)", advance="no") char (var%name) if (var%is_locked) write (u, "(A)", advance="no") "*" if (var%is_allocated) then write (u, "(A)", advance="no") " = " else if (var%type /= V_NONE) then write (u, "(A)", advance="no") " => " end if call var_write_val (var, u, "yes", pacified) end subroutine var_entry_write @ %def var_entry_write @ <>= subroutine var_write_val (var, u, advance, pacified, escape_tex) type(var_entry_t), intent(in) :: var integer, intent(in) :: u character(*), intent(in) :: advance logical, intent(in), optional :: pacified, escape_tex logical :: num_pac, et real(default) :: rval complex(default) :: cval character(len=7) :: fmt call pac_fmt (fmt, FMT_19, FMT_12, pacified) num_pac = .false.; if (present (pacified)) num_pac = pacified et = .false.; if (present (escape_tex)) et = escape_tex select case (var%type) case (V_NONE); write (u, '()', advance=advance) case (V_LOG) if (var%is_known) then if (var%lval) then write (u, "(A)", advance=advance) "true" else write (u, "(A)", advance=advance) "false" end if else write (u, "(A)", advance=advance) "[unknown logical]" end if case (V_INT) if (var%is_known) then write (u, "(I0)", advance=advance) var%ival else write (u, "(A)", advance=advance) "[unknown integer]" end if case (V_REAL) if (var%is_known) then rval = var%rval if (num_pac) then call pacify (rval, 10 * eps0) end if write (u, "(" // fmt // ")", advance=advance) rval else write (u, "(A)", advance=advance) "[unknown real]" end if case (V_CMPLX) if (var%is_known) then cval = var%cval if (num_pac) then call pacify (cval, 10 * eps0) end if write (u, "('('," // fmt // ",','," // fmt // ",')')", advance=advance) cval else write (u, "(A)", advance=advance) "[unknown complex]" end if case (V_SEV) if (var%is_known) then call var%pval%write (u, prefix=" ", pacified = pacified) else write (u, "(A)", advance=advance) "[unknown subevent]" end if case (V_PDG) if (var%is_known) then call var%aval%write (u); write (u, *) else write (u, "(A)", advance=advance) "[unknown PDG array]" end if case (V_STR) if (var%is_known) then if (et) then write (u, "(A)", advance=advance) '"' // char (replace ( & replace (var%sval, "_", "\_", every=.true.), "$", "\$" )) // '"' else write (u, "(A)", advance=advance) '"' // char (var%sval) // '"' end if else write (u, "(A)", advance=advance) "[unknown string]" end if case (V_OBS1_INT); write (u, "(A)", advance=advance) "[int] = unary observable" case (V_OBS2_INT); write (u, "(A)", advance=advance) "[int] = binary observable" case (V_OBSEV_INT); write (u, "(A)", advance=advance) "[int] = subeventary observable" case (V_OBS1_REAL); write (u, "(A)", advance=advance) "[real] = unary observable" case (V_OBS2_REAL); write (u, "(A)", advance=advance) "[real] = binary observable" case (V_OBSEV_REAL); write (u, "(A)", advance=advance) "[real] = subeventary observable" case (V_UOBS1_INT); write (u, "(A)", advance=advance) "[int] = unary user observable" case (V_UOBS2_INT); write (u, "(A)", advance=advance) "[int] = binary user observable" case (V_UOBS1_REAL); write (u, "(A)", advance=advance) "[real] = unary user observable" case (V_UOBS2_REAL); write (u, "(A)", advance=advance) "[real] = binary user observable" end select end subroutine var_write_val @ %def procedure @ \subsubsection{Accessing contents} <>= function var_entry_get_name (var) result (name) type(string_t) :: name type(var_entry_t), intent(in) :: var name = var%name end function var_entry_get_name function var_entry_get_type (var) result (type) integer :: type type(var_entry_t), intent(in) :: var type = var%type end function var_entry_get_type @ %def var_entry_get_name var_entry_get_type @ Return true if the variable is defined. This the case if it is allocated and known, or if it is a pointer. <>= function var_entry_is_defined (var) result (defined) logical :: defined type(var_entry_t), intent(in) :: var defined = var%is_defined end function var_entry_is_defined @ %def var_entry_is_defined @ Return true if the variable is locked. If [[force]] is active, always return false. <>= function var_entry_is_locked (var, force) result (locked) logical :: locked type(var_entry_t), intent(in) :: var logical, intent(in), optional :: force if (present (force)) then if (force) then locked = .false.; return end if end if locked = var%is_locked end function var_entry_is_locked @ %def var_entry_is_locked @ Return true if the variable is intrinsic <>= function var_entry_is_intrinsic (var) result (flag) logical :: flag type(var_entry_t), intent(in) :: var flag = var%is_intrinsic end function var_entry_is_intrinsic @ %def var_entry_is_intrinsic @ Return components <>= function var_entry_is_known (var) result (flag) logical :: flag type(var_entry_t), intent(in) :: var flag = var%is_known end function var_entry_is_known function var_entry_get_lval (var) result (lval) logical :: lval type(var_entry_t), intent(in) :: var lval = var%lval end function var_entry_get_lval function var_entry_get_ival (var) result (ival) integer :: ival type(var_entry_t), intent(in) :: var ival = var%ival end function var_entry_get_ival function var_entry_get_rval (var) result (rval) real(default) :: rval type(var_entry_t), intent(in) :: var rval = var%rval end function var_entry_get_rval function var_entry_get_cval (var) result (cval) complex(default) :: cval type(var_entry_t), intent(in) :: var cval = var%cval end function var_entry_get_cval function var_entry_get_aval (var) result (aval) type(pdg_array_t) :: aval type(var_entry_t), intent(in) :: var aval = var%aval end function var_entry_get_aval function var_entry_get_pval (var) result (pval) type(subevt_t) :: pval type(var_entry_t), intent(in) :: var pval = var%pval end function var_entry_get_pval function var_entry_get_sval (var) result (sval) type(string_t) :: sval type(var_entry_t), intent(in) :: var sval = var%sval end function var_entry_get_sval @ %def var_entry_get_lval @ %def var_entry_get_ival @ %def var_entry_get_rval @ %def var_entry_get_cval @ %def var_entry_get_aval @ %def var_entry_get_pval @ %def var_entry_get_sval @ Return pointers to components. <>= function var_entry_get_known_ptr (var) result (ptr) logical, pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%is_known end function var_entry_get_known_ptr function var_entry_get_lval_ptr (var) result (ptr) logical, pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%lval end function var_entry_get_lval_ptr function var_entry_get_ival_ptr (var) result (ptr) integer, pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%ival end function var_entry_get_ival_ptr function var_entry_get_rval_ptr (var) result (ptr) real(default), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%rval end function var_entry_get_rval_ptr function var_entry_get_cval_ptr (var) result (ptr) complex(default), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%cval end function var_entry_get_cval_ptr function var_entry_get_pval_ptr (var) result (ptr) type(subevt_t), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%pval end function var_entry_get_pval_ptr function var_entry_get_aval_ptr (var) result (ptr) type(pdg_array_t), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%aval end function var_entry_get_aval_ptr function var_entry_get_sval_ptr (var) result (ptr) type(string_t), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%sval end function var_entry_get_sval_ptr @ %def var_entry_get_known_ptr @ %def var_entry_get_lval_ptr var_entry_get_ival_ptr var_entry_get_rval_ptr @ %def var_entry_get_cval_ptr var_entry_get_aval_ptr var_entry_get_pval_ptr @ %def var_entry_get_sval_ptr @ Furthermore, <>= function var_entry_get_prt1_ptr (var) result (ptr) type(prt_t), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%prt1 end function var_entry_get_prt1_ptr function var_entry_get_prt2_ptr (var) result (ptr) type(prt_t), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%prt2 end function var_entry_get_prt2_ptr @ %def var_entry_get_prt1_ptr @ %def var_entry_get_prt2_ptr @ Subroutines might be safer than functions for procedure pointer transfer. <>= subroutine var_entry_assign_obs1_int_ptr (ptr, var) procedure(obs_unary_int), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%obs1_int end subroutine var_entry_assign_obs1_int_ptr subroutine var_entry_assign_obs1_real_ptr (ptr, var) procedure(obs_unary_real), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%obs1_real end subroutine var_entry_assign_obs1_real_ptr subroutine var_entry_assign_obs2_int_ptr (ptr, var) procedure(obs_binary_int), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%obs2_int end subroutine var_entry_assign_obs2_int_ptr subroutine var_entry_assign_obs2_real_ptr (ptr, var) procedure(obs_binary_real), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%obs2_real end subroutine var_entry_assign_obs2_real_ptr subroutine var_entry_assign_obsev_int_ptr (ptr, var) procedure(obs_sev_int), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%obsev_int end subroutine var_entry_assign_obsev_int_ptr subroutine var_entry_assign_obsev_real_ptr (ptr, var) procedure(obs_sev_real), pointer :: ptr type(var_entry_t), intent(in), target :: var ptr => var%obsev_real end subroutine var_entry_assign_obsev_real_ptr @ %def var_entry_assign_obs1_int_ptr var_entry_assign_obs1_real_ptr @ %def var_entry_assign_obs2_int_ptr var_entry_assign_obs2_real_ptr @ %def var_entry_assigbn_obsev_int_ptr var_entry_assign_obsev_real_ptr @ \subsection{Setting values} Undefine the value. <>= subroutine var_entry_clear_value (var) type(var_entry_t), intent(inout) :: var var%is_known = .false. end subroutine var_entry_clear_value @ %def var_entry_clear_value <>= recursive subroutine var_entry_set_log & (var, lval, is_known, verbose, model_name) type(var_entry_t), intent(inout) :: var logical, intent(in) :: lval logical, intent(in) :: is_known logical, intent(in), optional :: verbose type(string_t), intent(in), optional :: model_name integer :: u u = logfile_unit () var%lval = lval var%is_known = is_known var%is_defined = .true. if (present (verbose)) then if (verbose) then call var_entry_write (var, model_name=model_name) call var_entry_write (var, model_name=model_name, unit=u) if (u >= 0) flush (u) end if end if end subroutine var_entry_set_log recursive subroutine var_entry_set_int & (var, ival, is_known, verbose, model_name) type(var_entry_t), intent(inout) :: var integer, intent(in) :: ival logical, intent(in) :: is_known logical, intent(in), optional :: verbose type(string_t), intent(in), optional :: model_name integer :: u u = logfile_unit () var%ival = ival var%is_known = is_known var%is_defined = .true. if (present (verbose)) then if (verbose) then call var_entry_write (var, model_name=model_name) call var_entry_write (var, model_name=model_name, unit=u) if (u >= 0) flush (u) end if end if end subroutine var_entry_set_int recursive subroutine var_entry_set_real & (var, rval, is_known, verbose, model_name, pacified) type(var_entry_t), intent(inout) :: var real(default), intent(in) :: rval logical, intent(in) :: is_known logical, intent(in), optional :: verbose, pacified type(string_t), intent(in), optional :: model_name integer :: u u = logfile_unit () var%rval = rval var%is_known = is_known var%is_defined = .true. if (present (verbose)) then if (verbose) then call var_entry_write & (var, model_name=model_name, pacified = pacified) call var_entry_write & (var, model_name=model_name, unit=u, pacified = pacified) if (u >= 0) flush (u) end if end if end subroutine var_entry_set_real recursive subroutine var_entry_set_cmplx & (var, cval, is_known, verbose, model_name, pacified) type(var_entry_t), intent(inout) :: var complex(default), intent(in) :: cval logical, intent(in) :: is_known logical, intent(in), optional :: verbose, pacified type(string_t), intent(in), optional :: model_name integer :: u u = logfile_unit () var%cval = cval var%is_known = is_known var%is_defined = .true. if (present (verbose)) then if (verbose) then call var_entry_write & (var, model_name=model_name, pacified = pacified) call var_entry_write & (var, model_name=model_name, unit=u, pacified = pacified) if (u >= 0) flush (u) end if end if end subroutine var_entry_set_cmplx recursive subroutine var_entry_set_pdg_array & (var, aval, is_known, verbose, model_name) type(var_entry_t), intent(inout) :: var type(pdg_array_t), intent(in) :: aval logical, intent(in) :: is_known logical, intent(in), optional :: verbose type(string_t), intent(in), optional :: model_name integer :: u u = logfile_unit () var%aval = aval var%is_known = is_known var%is_defined = .true. if (present (verbose)) then if (verbose) then call var_entry_write (var, model_name=model_name) call var_entry_write (var, model_name=model_name, unit=u) if (u >= 0) flush (u) end if end if end subroutine var_entry_set_pdg_array recursive subroutine var_entry_set_subevt & (var, pval, is_known, verbose, model_name) type(var_entry_t), intent(inout) :: var type(subevt_t), intent(in) :: pval logical, intent(in) :: is_known logical, intent(in), optional :: verbose type(string_t), intent(in), optional :: model_name integer :: u u = logfile_unit () var%pval = pval var%is_known = is_known var%is_defined = .true. if (present (verbose)) then if (verbose) then call var_entry_write (var, model_name=model_name) call var_entry_write (var, model_name=model_name, unit=u) if (u >= 0) flush (u) end if end if end subroutine var_entry_set_subevt recursive subroutine var_entry_set_string & (var, sval, is_known, verbose, model_name) type(var_entry_t), intent(inout) :: var type(string_t), intent(in) :: sval logical, intent(in) :: is_known logical, intent(in), optional :: verbose type(string_t), intent(in), optional :: model_name integer :: u u = logfile_unit () var%sval = sval var%is_known = is_known var%is_defined = .true. if (present (verbose)) then if (verbose) then call var_entry_write (var, model_name=model_name) call var_entry_write (var, model_name=model_name, unit=u) if (u >= 0) flush (u) end if end if end subroutine var_entry_set_string @ %def var_entry_set_log @ %def var_entry_set_int @ %def var_entry_set_real @ %def var_entry_set_cmplx @ %def var_entry_set_pdg_array @ %def var_entry_set_subevt @ %def var_entry_set_string @ <>= pure subroutine var_entry_set_description (var_entry, description) type(var_entry_t), intent(inout) :: var_entry type(string_t), intent(in) :: description var_entry%description = description end subroutine var_entry_set_description @ %def var_entry_set_description @ \subsection{Copies and pointer variables} Initialize an entry with a copy of an existing variable entry. The copy is physically allocated with the same type as the original. <>= subroutine var_entry_init_copy (var, original, user) type(var_entry_t), intent(out) :: var type(var_entry_t), intent(in), target :: original logical, intent(in), optional :: user type(string_t) :: name logical :: intrinsic name = var_entry_get_name (original) intrinsic = original%is_intrinsic select case (original%type) case (V_LOG) call var_entry_init_log (var, name, intrinsic=intrinsic, user=user) case (V_INT) call var_entry_init_int (var, name, intrinsic=intrinsic, user=user) case (V_REAL) call var_entry_init_real (var, name, intrinsic=intrinsic, user=user) case (V_CMPLX) call var_entry_init_cmplx (var, name, intrinsic=intrinsic, user=user) case (V_SEV) call var_entry_init_subevt (var, name, intrinsic=intrinsic, user=user) case (V_PDG) call var_entry_init_pdg_array (var, name, intrinsic=intrinsic, user=user) case (V_STR) call var_entry_init_string (var, name, intrinsic=intrinsic, user=user) end select end subroutine var_entry_init_copy @ %def var_entry_init_copy @ Copy the value of an entry. The target variable entry must be initialized correctly. <>= subroutine var_entry_copy_value (var, original) type(var_entry_t), intent(inout) :: var type(var_entry_t), intent(in), target :: original if (var_entry_is_known (original)) then select case (original%type) case (V_LOG) call var_entry_set_log (var, var_entry_get_lval (original), .true.) case (V_INT) call var_entry_set_int (var, var_entry_get_ival (original), .true.) case (V_REAL) call var_entry_set_real (var, var_entry_get_rval (original), .true.) case (V_CMPLX) call var_entry_set_cmplx (var, var_entry_get_cval (original), .true.) case (V_SEV) call var_entry_set_subevt (var, var_entry_get_pval (original), .true.) case (V_PDG) call var_entry_set_pdg_array (var, var_entry_get_aval (original), .true.) case (V_STR) call var_entry_set_string (var, var_entry_get_sval (original), .true.) end select else call var_entry_clear (var) end if end subroutine var_entry_copy_value @ %def var_entry_copy_value @ \subsection{Variable lists} \subsubsection{The type} Variable lists can be linked together. No initializer needed. They are deleted separately. <>= public :: var_list_t <>= type, extends (vars_t) :: var_list_t private type(var_entry_t), pointer :: first => null () type(var_entry_t), pointer :: last => null () type(var_list_t), pointer :: next => null () contains <> end type var_list_t @ %def var_list_t @ \subsubsection{Constructors} Implementation of the [[link]] deferred method. The implementation restricts itself to var lists of the same type. We might need to relax this constraint. <>= procedure :: link => var_list_link <>= module subroutine var_list_link (vars, target_vars) class(var_list_t), intent(inout) :: vars class(vars_t), intent(in), target :: target_vars end subroutine var_list_link <>= module subroutine var_list_link (vars, target_vars) class(var_list_t), intent(inout) :: vars class(vars_t), intent(in), target :: target_vars select type (target_vars) type is (var_list_t) vars%next => target_vars class default call msg_bug ("var_list_link: unsupported target type") end select end subroutine var_list_link @ %def var_list_link @ Append a new entry to an existing list. <>= subroutine var_list_append (var_list, var, verbose) type(var_list_t), intent(inout), target :: var_list type(var_entry_t), intent(inout), target :: var logical, intent(in), optional :: verbose if (associated (var_list%last)) then var%previous => var_list%last var_list%last%next => var else var%previous => null () var_list%first => var end if var_list%last => var if (present (verbose)) then if (verbose) call var_entry_write (var) end if end subroutine var_list_append @ %def var_list_append @ Sort a list. <>= procedure :: sort => var_list_sort <>= module subroutine var_list_sort (var_list) class(var_list_t), intent(inout) :: var_list end subroutine var_list_sort <>= module subroutine var_list_sort (var_list) class(var_list_t), intent(inout) :: var_list type(var_entry_t), pointer :: var, previous if (associated (var_list%first)) then var => var_list%first do while (associated (var)) previous => var%previous do while (associated (previous)) if (larger_var (previous, var)) then call var_list%swap_with_next (previous) end if previous => previous%previous end do var => var%next end do end if end subroutine var_list_sort @ %def var_list_sort @ <>= pure function larger_var (var1, var2) result (larger) logical :: larger type(var_entry_t), intent(in) :: var1, var2 type(string_t) :: str1, str2 str1 = replace (var1%name, "?", "") str1 = replace (str1, "$", "") str2 = replace (var2%name, "?", "") str2 = replace (str2, "$", "") larger = str1 > str2 end function larger_var @ %def larger_var @ <>= procedure :: get_previous => var_list_get_previous <>= module function var_list_get_previous & (var_list, var_entry) result (previous) type(var_entry_t), pointer :: previous class(var_list_t), intent(in) :: var_list type(var_entry_t), intent(in) :: var_entry end function var_list_get_previous <>= module function var_list_get_previous & (var_list, var_entry) result (previous) type(var_entry_t), pointer :: previous class(var_list_t), intent(in) :: var_list type(var_entry_t), intent(in) :: var_entry previous => var_list%first if (previous%name == var_entry%name) then previous => null () else do while (associated (previous)) if (previous%next%name == var_entry%name) exit previous => previous%next end do end if end function var_list_get_previous @ %def var_list_get_previous @ <>= procedure :: swap_with_next => var_list_swap_with_next <>= module subroutine var_list_swap_with_next (var_list, var_entry) class(var_list_t), intent(inout) :: var_list type(var_entry_t), intent(in) :: var_entry end subroutine var_list_swap_with_next <>= module subroutine var_list_swap_with_next (var_list, var_entry) class(var_list_t), intent(inout) :: var_list type(var_entry_t), intent(in) :: var_entry type(var_entry_t), pointer :: previous, this, next, next_next previous => var_list%get_previous (var_entry) if (.not. associated (previous)) then this => var_list%first else this => previous%next end if next => this%next next_next => next%next if (associated (previous)) then previous%next => next next%previous => previous else var_list%first => next next%previous => null () end if this%next => next_next if (associated (next_next)) then next_next%previous => this end if next%next => this this%previous => next if (.not. associated (next%next)) then var_list%last => next end if end subroutine var_list_swap_with_next @ %def var_list_swap_with_next @ Public methods for expanding the variable list (as subroutines) <>= generic :: append_log => var_list_append_log_s, var_list_append_log_c procedure, private :: var_list_append_log_s procedure, private :: var_list_append_log_c generic :: append_int => var_list_append_int_s, var_list_append_int_c procedure, private :: var_list_append_int_s procedure, private :: var_list_append_int_c generic :: append_real => var_list_append_real_s, var_list_append_real_c procedure, private :: var_list_append_real_s procedure, private :: var_list_append_real_c generic :: append_cmplx => var_list_append_cmplx_s, var_list_append_cmplx_c procedure, private :: var_list_append_cmplx_s procedure, private :: var_list_append_cmplx_c generic :: append_subevt => var_list_append_subevt_s, var_list_append_subevt_c procedure, private :: var_list_append_subevt_s procedure, private :: var_list_append_subevt_c generic :: append_pdg_array => var_list_append_pdg_array_s, var_list_append_pdg_array_c procedure, private :: var_list_append_pdg_array_s procedure, private :: var_list_append_pdg_array_c generic :: append_string => var_list_append_string_s, var_list_append_string_c procedure, private :: var_list_append_string_s procedure, private :: var_list_append_string_c <>= interface var_list_append_log module procedure var_list_append_log_s module procedure var_list_append_log_c end interface interface var_list_append_int module procedure var_list_append_int_s module procedure var_list_append_int_c end interface interface var_list_append_real module procedure var_list_append_real_s module procedure var_list_append_real_c end interface interface var_list_append_cmplx module procedure var_list_append_cmplx_s module procedure var_list_append_cmplx_c end interface interface var_list_append_subevt module procedure var_list_append_subevt_s module procedure var_list_append_subevt_c end interface interface var_list_append_pdg_array module procedure var_list_append_pdg_array_s module procedure var_list_append_pdg_array_c end interface interface var_list_append_string module procedure var_list_append_string_s module procedure var_list_append_string_c end interface <>= module subroutine var_list_append_log_s & (var_list, name, lval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name logical, intent(in), optional :: lval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description end subroutine var_list_append_log_s module subroutine var_list_append_int_s & (var_list, name, ival, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name integer, intent(in), optional :: ival logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description end subroutine var_list_append_int_s module subroutine var_list_append_real_s & (var_list, name, rval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name real(default), intent(in), optional :: rval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description end subroutine var_list_append_real_s module subroutine var_list_append_cmplx_s & (var_list, name, cval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name complex(default), intent(in), optional :: cval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description end subroutine var_list_append_cmplx_s module subroutine var_list_append_subevt_s & (var_list, name, pval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(subevt_t), intent(in), optional :: pval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description end subroutine var_list_append_subevt_s module subroutine var_list_append_pdg_array_s & (var_list, name, aval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(pdg_array_t), intent(in), optional :: aval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description end subroutine var_list_append_pdg_array_s module subroutine var_list_append_string_s & (var_list, name, sval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(string_t), intent(in), optional :: sval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description end subroutine var_list_append_string_s module subroutine var_list_append_log_c & (var_list, name, lval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name logical, intent(in), optional :: lval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description end subroutine var_list_append_log_c module subroutine var_list_append_int_c & (var_list, name, ival, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name integer, intent(in), optional :: ival logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description end subroutine var_list_append_int_c module subroutine var_list_append_real_c & (var_list, name, rval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name real(default), intent(in), optional :: rval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description end subroutine var_list_append_real_c module subroutine var_list_append_cmplx_c & (var_list, name, cval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name complex(default), intent(in), optional :: cval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description end subroutine var_list_append_cmplx_c module subroutine var_list_append_subevt_c & (var_list, name, pval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name type(subevt_t), intent(in), optional :: pval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description end subroutine var_list_append_subevt_c module subroutine var_list_append_pdg_array_c & (var_list, name, aval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name type(pdg_array_t), intent(in), optional :: aval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description end subroutine var_list_append_pdg_array_c module subroutine var_list_append_string_c & (var_list, name, sval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name character(*), intent(in), optional :: sval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description end subroutine var_list_append_string_c <>= module subroutine var_list_append_log_s & (var_list, name, lval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name logical, intent(in), optional :: lval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_log (var, name, lval, intrinsic, user) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_log_s module subroutine var_list_append_int_s & (var_list, name, ival, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name integer, intent(in), optional :: ival logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_int (var, name, ival, intrinsic, user) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_int_s module subroutine var_list_append_real_s & (var_list, name, rval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name real(default), intent(in), optional :: rval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_real (var, name, rval, intrinsic, user) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_real_s module subroutine var_list_append_cmplx_s & (var_list, name, cval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name complex(default), intent(in), optional :: cval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_cmplx (var, name, cval, intrinsic, user) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_cmplx_s module subroutine var_list_append_subevt_s & (var_list, name, pval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(subevt_t), intent(in), optional :: pval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_subevt (var, name, pval, intrinsic, user) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_subevt_s module subroutine var_list_append_pdg_array_s & (var_list, name, aval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(pdg_array_t), intent(in), optional :: aval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_pdg_array (var, name, aval, intrinsic, user) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_pdg_array_s module subroutine var_list_append_string_s & (var_list, name, sval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(string_t), intent(in), optional :: sval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_string (var, name, sval, intrinsic, user) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_string_s module subroutine var_list_append_log_c & (var_list, name, lval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name logical, intent(in), optional :: lval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description call var_list_append_log_s & (var_list, var_str (name), lval, locked, verbose, & intrinsic, user, description) end subroutine var_list_append_log_c module subroutine var_list_append_int_c & (var_list, name, ival, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name integer, intent(in), optional :: ival logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description call var_list_append_int_s & (var_list, var_str (name), ival, locked, verbose, & intrinsic, user, description) end subroutine var_list_append_int_c module subroutine var_list_append_real_c & (var_list, name, rval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name real(default), intent(in), optional :: rval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description call var_list_append_real_s & (var_list, var_str (name), rval, locked, verbose, & intrinsic, user, description) end subroutine var_list_append_real_c module subroutine var_list_append_cmplx_c & (var_list, name, cval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name complex(default), intent(in), optional :: cval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description call var_list_append_cmplx_s & (var_list, var_str (name), cval, locked, verbose, & intrinsic, user, description) end subroutine var_list_append_cmplx_c module subroutine var_list_append_subevt_c & (var_list, name, pval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name type(subevt_t), intent(in), optional :: pval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description call var_list_append_subevt_s & (var_list, var_str (name), pval, locked, verbose, & intrinsic, user, description) end subroutine var_list_append_subevt_c module subroutine var_list_append_pdg_array_c & (var_list, name, aval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name type(pdg_array_t), intent(in), optional :: aval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description call var_list_append_pdg_array_s & (var_list, var_str (name), aval, locked, verbose, & intrinsic, user, description) end subroutine var_list_append_pdg_array_c module subroutine var_list_append_string_c & (var_list, name, sval, locked, verbose, intrinsic, user, description) class(var_list_t), intent(inout) :: var_list character(*), intent(in) :: name character(*), intent(in), optional :: sval logical, intent(in), optional :: locked, verbose, intrinsic, user type(string_t), intent(in), optional :: description if (present (sval)) then call var_list_append_string_s & (var_list, var_str (name), var_str (sval), & locked, verbose, intrinsic, user, description) else call var_list_append_string_s & (var_list, var_str (name), & locked=locked, verbose=verbose, intrinsic=intrinsic, & user=user, description=description) end if end subroutine var_list_append_string_c @ %def var_list_append_log @ %def var_list_append_int @ %def var_list_append_real @ %def var_list_append_cmplx @ %def var_list_append_subevt @ %def var_list_append_pdg_array @ %def var_list_append_string <>= procedure :: append_log_ptr => var_list_append_log_ptr procedure :: append_int_ptr => var_list_append_int_ptr procedure :: append_real_ptr => var_list_append_real_ptr procedure :: append_cmplx_ptr => var_list_append_cmplx_ptr procedure :: append_pdg_array_ptr => var_list_append_pdg_array_ptr procedure :: append_subevt_ptr => var_list_append_subevt_ptr procedure :: append_string_ptr => var_list_append_string_ptr <>= module subroutine var_list_append_log_ptr & (var_list, name, lval, is_known, locked, verbose, & intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name logical, intent(in), target :: lval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description end subroutine var_list_append_log_ptr module subroutine var_list_append_int_ptr & (var_list, name, ival, is_known, locked, verbose, & intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name integer, intent(in), target :: ival logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description end subroutine var_list_append_int_ptr module subroutine var_list_append_real_ptr & (var_list, name, rval, is_known, locked, verbose, & intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name real(default), intent(in), target :: rval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description end subroutine var_list_append_real_ptr module subroutine var_list_append_cmplx_ptr & (var_list, name, cval, is_known, locked, verbose, & intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name complex(default), intent(in), target :: cval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description end subroutine var_list_append_cmplx_ptr module subroutine var_list_append_pdg_array_ptr & (var_list, name, aval, is_known, locked, verbose, & intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(pdg_array_t), intent(in), target :: aval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description end subroutine var_list_append_pdg_array_ptr module subroutine var_list_append_subevt_ptr & (var_list, name, pval, is_known, locked, verbose, & intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(subevt_t), intent(in), target :: pval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description end subroutine var_list_append_subevt_ptr module subroutine var_list_append_string_ptr & (var_list, name, sval, is_known, locked, verbose, & intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(string_t), intent(in), target :: sval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description end subroutine var_list_append_string_ptr <>= module subroutine var_list_append_log_ptr & (var_list, name, lval, is_known, locked, verbose, & intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name logical, intent(in), target :: lval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_log_ptr (var, name, lval, is_known, intrinsic) if (present (description)) & call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_log_ptr module subroutine var_list_append_int_ptr & (var_list, name, ival, is_known, locked, verbose, intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name integer, intent(in), target :: ival logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_int_ptr (var, name, ival, is_known, intrinsic) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_int_ptr module subroutine var_list_append_real_ptr & (var_list, name, rval, is_known, locked, verbose, intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name real(default), intent(in), target :: rval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_real_ptr (var, name, rval, is_known, intrinsic) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_real_ptr module subroutine var_list_append_cmplx_ptr & (var_list, name, cval, is_known, locked, verbose, intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name complex(default), intent(in), target :: cval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_cmplx_ptr (var, name, cval, is_known, intrinsic) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_cmplx_ptr module subroutine var_list_append_pdg_array_ptr & (var_list, name, aval, is_known, locked, verbose, intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(pdg_array_t), intent(in), target :: aval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_pdg_array_ptr (var, name, aval, is_known, intrinsic) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_pdg_array_ptr module subroutine var_list_append_subevt_ptr & (var_list, name, pval, is_known, locked, verbose, intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(subevt_t), intent(in), target :: pval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_subevt_ptr (var, name, pval, is_known, intrinsic) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_subevt_ptr module subroutine var_list_append_string_ptr & (var_list, name, sval, is_known, locked, verbose, intrinsic, description) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(string_t), intent(in), target :: sval logical, intent(in), target :: is_known logical, intent(in), optional :: locked, verbose, intrinsic type(string_t), intent(in), optional :: description type(var_entry_t), pointer :: var allocate (var) call var_entry_init_string_ptr (var, name, sval, is_known, intrinsic) if (present (description)) call var_entry_set_description (var, description) if (present (locked)) call var_entry_lock (var, locked) call var_list_append (var_list, var, verbose) end subroutine var_list_append_string_ptr @ %def var_list_append_log_ptr @ %def var_list_append_int_ptr @ %def var_list_append_real_ptr @ %def var_list_append_cmplx_ptr @ %def var_list_append_pdg_array_ptr @ %def var_list_append_subevt_ptr @ \subsubsection{Finalizer} Finalize, delete the list entry by entry. The link itself is kept intact. Follow link and delete recursively only if requested explicitly. <>= procedure :: final => var_list_final <>= recursive module subroutine var_list_final (vars, follow_link) class(var_list_t), intent(inout) :: vars logical, intent(in), optional :: follow_link end subroutine var_list_final <>= recursive module subroutine var_list_final (vars, follow_link) class(var_list_t), intent(inout) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var vars%last => null () do while (associated (vars%first)) var => vars%first vars%first => var%next call var_entry_final (var) deallocate (var) end do if (present (follow_link)) then if (follow_link) then if (associated (vars%next)) then call vars%next%final (follow_link) deallocate (vars%next) end if end if end if end subroutine var_list_final @ %def var_list_final @ \subsubsection{Output} Show variable list with precise control over options. E.g., show only variables of a certain type. Many options, thus not an ordinary [[write]] method. <>= procedure :: write => var_list_write <>= recursive module subroutine var_list_write & (var_list, unit, follow_link, only_type, prefix, model_name, & intrinsic, pacified, descriptions, ascii_output) class(var_list_t), intent(in), target :: var_list integer, intent(in), optional :: unit logical, intent(in), optional :: follow_link integer, intent(in), optional :: only_type character(*), intent(in), optional :: prefix type(string_t), intent(in), optional :: model_name logical, intent(in), optional :: intrinsic logical, intent(in), optional :: pacified logical, intent(in), optional :: descriptions logical, intent(in), optional :: ascii_output end subroutine var_list_write <>= recursive module subroutine var_list_write & (var_list, unit, follow_link, only_type, prefix, model_name, & intrinsic, pacified, descriptions, ascii_output) class(var_list_t), intent(in), target :: var_list integer, intent(in), optional :: unit logical, intent(in), optional :: follow_link integer, intent(in), optional :: only_type character(*), intent(in), optional :: prefix type(string_t), intent(in), optional :: model_name logical, intent(in), optional :: intrinsic logical, intent(in), optional :: pacified logical, intent(in), optional :: descriptions logical, intent(in), optional :: ascii_output type(var_entry_t), pointer :: var integer :: u, length logical :: write_this, write_next u = given_output_unit (unit); if (u < 0) return if (present (prefix)) length = len (prefix) var => var_list%first if (associated (var)) then do while (associated (var)) if (present (only_type)) then write_this = only_type == var%type else write_this = .true. end if if (write_this .and. present (prefix)) then if (prefix /= extract (var%name, 1, length)) & write_this = .false. end if if (write_this) then call var_entry_write & (var, unit, model_name=model_name, & intrinsic=intrinsic, pacified=pacified, & descriptions=descriptions, ascii_output=ascii_output) end if var => var%next end do end if if (present (follow_link)) then write_next = follow_link .and. associated (var_list%next) else write_next = associated (var_list%next) end if if (write_next) then call var_list_write (var_list%next, & unit, follow_link, only_type, prefix, model_name, & intrinsic, pacified) end if end subroutine var_list_write @ %def var_list_write @ Write only a certain variable. <>= procedure :: write_var => var_list_write_var <>= recursive module subroutine var_list_write_var & (var_list, name, unit, type, follow_link, & model_name, pacified, defined, descriptions, ascii_output) class(var_list_t), intent(in), target :: var_list type(string_t), intent(in) :: name integer, intent(in), optional :: unit integer, intent(in), optional :: type logical, intent(in), optional :: follow_link type(string_t), intent(in), optional :: model_name logical, intent(in), optional :: pacified logical, intent(in), optional :: defined logical, intent(in), optional :: descriptions logical, intent(in), optional :: ascii_output end subroutine var_list_write_var <>= recursive module subroutine var_list_write_var & (var_list, name, unit, type, follow_link, & model_name, pacified, defined, descriptions, ascii_output) class(var_list_t), intent(in), target :: var_list type(string_t), intent(in) :: name integer, intent(in), optional :: unit integer, intent(in), optional :: type logical, intent(in), optional :: follow_link type(string_t), intent(in), optional :: model_name logical, intent(in), optional :: pacified logical, intent(in), optional :: defined logical, intent(in), optional :: descriptions logical, intent(in), optional :: ascii_output type(var_entry_t), pointer :: var integer :: u u = given_output_unit (unit); if (u < 0) return var => var_list_get_var_ptr & (var_list, name, type, follow_link=follow_link, defined=defined) if (associated (var)) then call var_entry_write & (var, unit, model_name = model_name, & pacified = pacified, & descriptions=descriptions, ascii_output=ascii_output) else write (u, "(A)") char (name) // " = [undefined]" end if end subroutine var_list_write_var @ %def var_list_write_var @ \subsection{Tools} Return a pointer to the variable list linked to by the current one. <>= function var_list_get_next_ptr (var_list) result (next_ptr) type(var_list_t), pointer :: next_ptr type(var_list_t), intent(in) :: var_list next_ptr => var_list%next end function var_list_get_next_ptr @ %def var_list_get_next_ptr @ Used by [[eval_trees]]: Return a pointer to the variable with the requested name. If no such name exists, return a null pointer. In that case, try the next list if present, unless [[follow_link]] is unset. If [[defined]] is set, ignore entries that exist but are undefined. <>= recursive function var_list_get_var_ptr & (var_list, name, type, follow_link, defined) result (var) type(var_entry_t), pointer :: var type(var_list_t), intent(in), target :: var_list type(string_t), intent(in) :: name integer, intent(in), optional :: type logical, intent(in), optional :: follow_link, defined logical :: ignore_undef, search_next ignore_undef = .true.; if (present (defined)) ignore_undef = .not. defined var => var_list%first if (present (type)) then do while (associated (var)) if (var%type == type) then if (var%name == name) then if (ignore_undef .or. var%is_defined) return end if end if var => var%next end do else do while (associated (var)) if (var%name == name) then if (ignore_undef .or. var%is_defined) return end if var => var%next end do end if search_next = associated (var_list%next) if (present (follow_link)) & search_next = search_next .and. follow_link if (search_next) & var => var_list_get_var_ptr & (var_list%next, name, type, defined=defined) end function var_list_get_var_ptr @ %def var_list_get_var_ptr @ Return the variable type <>= procedure :: get_type => var_list_get_type <>= module function var_list_get_type & (var_list, name, follow_link) result (type) class(var_list_t), intent(in), target :: var_list type(string_t), intent(in) :: name logical, intent(in), optional :: follow_link integer :: type end function var_list_get_type <>= module function var_list_get_type & (var_list, name, follow_link) result (type) class(var_list_t), intent(in), target :: var_list type(string_t), intent(in) :: name logical, intent(in), optional :: follow_link integer :: type type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, follow_link=follow_link) if (associated (var)) then type = var%type else type = V_NONE end if end function var_list_get_type @ %def var_list_get_type @ Return true if the variable exists in the current list. <>= procedure :: contains => var_list_exists <>= module function var_list_exists (vars, name, follow_link) result (lval) logical :: lval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link end function var_list_exists <>= module function var_list_exists (vars, name, follow_link) result (lval) logical :: lval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) lval = associated (var) end function var_list_exists @ %def var_list_exists @ Return true if the variable is declared as intrinsic. (This is not a property of the abstract [[vars_t]] type, and therefore the method is not inherited.) <>= procedure :: is_intrinsic => var_list_is_intrinsic <>= module function var_list_is_intrinsic & (vars, name, follow_link) result (lval) logical :: lval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link end function var_list_is_intrinsic <>= module function var_list_is_intrinsic & (vars, name, follow_link) result (lval) logical :: lval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then lval = var%is_intrinsic else lval = .false. end if end function var_list_is_intrinsic @ %def var_list_is_intrinsic @ Return true if the value is known. <>= procedure :: is_known => var_list_is_known <>= module function var_list_is_known (vars, name, follow_link) result (lval) logical :: lval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link end function var_list_is_known <>= module function var_list_is_known (vars, name, follow_link) result (lval) logical :: lval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then lval = var%is_known else lval = .false. end if end function var_list_is_known @ %def var_list_is_known @ Return true if the value is locked. (This is not a property of the abstract [[vars_t]] type, and therefore the method is not inherited.) <>= procedure :: is_locked => var_list_is_locked <>= module function var_list_is_locked (vars, name, follow_link) result (lval) logical :: lval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link end function var_list_is_locked <>= module function var_list_is_locked (vars, name, follow_link) result (lval) logical :: lval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then lval = var_entry_is_locked (var) else lval = .false. end if end function var_list_is_locked @ %def var_list_is_locked @ Return several properties at once. <>= procedure :: get_var_properties => var_list_get_var_properties <>= module subroutine var_list_get_var_properties & (vars, name, req_type, follow_link, & type, is_defined, is_known, is_locked) class(var_list_t), intent(in) :: vars type(string_t), intent(in) :: name integer, intent(in), optional :: req_type logical, intent(in), optional :: follow_link integer, intent(out), optional :: type logical, intent(out), optional :: is_defined, is_known, is_locked end subroutine var_list_get_var_properties <>= module subroutine var_list_get_var_properties & (vars, name, req_type, follow_link, & type, is_defined, is_known, is_locked) class(var_list_t), intent(in) :: vars type(string_t), intent(in) :: name integer, intent(in), optional :: req_type logical, intent(in), optional :: follow_link integer, intent(out), optional :: type logical, intent(out), optional :: is_defined, is_known, is_locked type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, type=req_type, follow_link=follow_link) if (associated (var)) then if (present (type)) type = var_entry_get_type (var) if (present (is_defined)) is_defined = var_entry_is_defined (var) if (present (is_known)) is_known = var_entry_is_known (var) if (present (is_locked)) is_locked = var_entry_is_locked (var) else if (present (type)) type = V_NONE if (present (is_defined)) is_defined = .false. if (present (is_known)) is_known = .false. if (present (is_locked)) is_locked = .false. end if end subroutine var_list_get_var_properties @ %def var_list_get_var_properties @ Return the value, assuming that the type is correct. We consider only variable entries that have been [[defined]]. For convenience, allow both variable and fixed-length (literal) strings. <>= procedure :: get_lval => var_list_get_lval procedure :: get_ival => var_list_get_ival procedure :: get_rval => var_list_get_rval procedure :: get_cval => var_list_get_cval procedure :: get_pval => var_list_get_pval procedure :: get_aval => var_list_get_aval procedure :: get_sval => var_list_get_sval <>= module function var_list_get_lval (vars, name, follow_link) result (lval) logical :: lval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link end function var_list_get_lval module function var_list_get_ival (vars, name, follow_link) result (ival) integer :: ival type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link end function var_list_get_ival module function var_list_get_rval (vars, name, follow_link) result (rval) real(default) :: rval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link end function var_list_get_rval module function var_list_get_cval (vars, name, follow_link) result (cval) complex(default) :: cval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link end function var_list_get_cval module function var_list_get_aval (vars, name, follow_link) result (aval) type(pdg_array_t) :: aval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link end function var_list_get_aval module function var_list_get_pval (vars, name, follow_link) result (pval) type(subevt_t) :: pval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link end function var_list_get_pval module function var_list_get_sval (vars, name, follow_link) result (sval) type(string_t) :: sval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link end function var_list_get_sval <>= module function var_list_get_lval (vars, name, follow_link) result (lval) logical :: lval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, V_LOG, follow_link, defined=.true.) if (associated (var)) then if (var_has_value (var)) then lval = var%lval else lval = .false. end if else lval = .false. end if end function var_list_get_lval module function var_list_get_ival (vars, name, follow_link) result (ival) integer :: ival type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, V_INT, follow_link, defined=.true.) if (associated (var)) then if (var_has_value (var)) then ival = var%ival else ival = 0 end if else ival = 0 end if end function var_list_get_ival module function var_list_get_rval (vars, name, follow_link) result (rval) real(default) :: rval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, V_REAL, follow_link, defined=.true.) if (associated (var)) then if (var_has_value (var)) then rval = var%rval else rval = 0 end if else rval = 0 end if end function var_list_get_rval module function var_list_get_cval (vars, name, follow_link) result (cval) complex(default) :: cval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, V_CMPLX, follow_link, defined=.true.) if (associated (var)) then if (var_has_value (var)) then cval = var%cval else cval = 0 end if else cval = 0 end if end function var_list_get_cval module function var_list_get_aval (vars, name, follow_link) result (aval) type(pdg_array_t) :: aval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, V_PDG, follow_link, defined=.true.) if (associated (var)) then if (var_has_value (var)) then aval = var%aval end if end if end function var_list_get_aval module function var_list_get_pval (vars, name, follow_link) result (pval) type(subevt_t) :: pval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, V_SEV, follow_link, defined=.true.) if (associated (var)) then if (var_has_value (var)) then pval = var%pval end if end if end function var_list_get_pval module function var_list_get_sval (vars, name, follow_link) result (sval) type(string_t) :: sval type(string_t), intent(in) :: name class(var_list_t), intent(in) :: vars logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr & (vars, name, V_STR, follow_link, defined=.true.) if (associated (var)) then if (var_has_value (var)) then sval = var%sval else sval = "" end if else sval = "" end if end function var_list_get_sval @ %def var_list_get_lval @ %def var_list_get_ival @ %def var_list_get_rval @ %def var_list_get_cval @ %def var_list_get_pval @ %def var_list_get_aval @ %def var_list_get_sval @ Check for a valid value, given a pointer. Issue error messages if invalid. <>= function var_has_value (var) result (valid) logical :: valid type(var_entry_t), pointer :: var if (associated (var)) then if (var%is_known) then valid = .true. else call msg_error ("The value of variable '" // char (var%name) & // "' is unknown but must be known at this point.") valid = .false. end if else call msg_error ("Variable '" // char (var%name) & // "' is undefined but must have a known value at this point.") valid = .false. end if end function var_has_value @ %def var_has_value @ Return pointers instead of values, including a pointer to the [[known]] entry. <>= procedure :: get_lptr => var_list_get_lptr procedure :: get_iptr => var_list_get_iptr procedure :: get_rptr => var_list_get_rptr procedure :: get_cptr => var_list_get_cptr procedure :: get_aptr => var_list_get_aptr procedure :: get_pptr => var_list_get_pptr procedure :: get_sptr => var_list_get_sptr <>= module subroutine var_list_get_lptr (var_list, name, lptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name logical, pointer, intent(out) :: lptr logical, pointer, intent(out), optional :: known end subroutine var_list_get_lptr module subroutine var_list_get_iptr (var_list, name, iptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name integer, pointer, intent(out) :: iptr logical, pointer, intent(out), optional :: known end subroutine var_list_get_iptr module subroutine var_list_get_rptr (var_list, name, rptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name real(default), pointer, intent(out) :: rptr logical, pointer, intent(out), optional :: known end subroutine var_list_get_rptr module subroutine var_list_get_cptr (var_list, name, cptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name complex(default), pointer, intent(out) :: cptr logical, pointer, intent(out), optional :: known end subroutine var_list_get_cptr module subroutine var_list_get_aptr (var_list, name, aptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name type(pdg_array_t), pointer, intent(out) :: aptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var end subroutine var_list_get_aptr module subroutine var_list_get_pptr (var_list, name, pptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name type(subevt_t), pointer, intent(out) :: pptr logical, pointer, intent(out), optional :: known end subroutine var_list_get_pptr module subroutine var_list_get_sptr (var_list, name, sptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name type(string_t), pointer, intent(out) :: sptr logical, pointer, intent(out), optional :: known end subroutine var_list_get_sptr <>= module subroutine var_list_get_lptr (var_list, name, lptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name logical, pointer, intent(out) :: lptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_LOG) if (associated (var)) then lptr => var_entry_get_lval_ptr (var) if (present (known)) known => var_entry_get_known_ptr (var) else lptr => null () if (present (known)) known => null () end if end subroutine var_list_get_lptr module subroutine var_list_get_iptr (var_list, name, iptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name integer, pointer, intent(out) :: iptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_INT) if (associated (var)) then iptr => var_entry_get_ival_ptr (var) if (present (known)) known => var_entry_get_known_ptr (var) else iptr => null () if (present (known)) known => null () end if end subroutine var_list_get_iptr module subroutine var_list_get_rptr (var_list, name, rptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name real(default), pointer, intent(out) :: rptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_REAL) if (associated (var)) then rptr => var_entry_get_rval_ptr (var) if (present (known)) known => var_entry_get_known_ptr (var) else rptr => null () if (present (known)) known => null () end if end subroutine var_list_get_rptr module subroutine var_list_get_cptr (var_list, name, cptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name complex(default), pointer, intent(out) :: cptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_CMPLX) if (associated (var)) then cptr => var_entry_get_cval_ptr (var) if (present (known)) known => var_entry_get_known_ptr (var) else cptr => null () if (present (known)) known => null () end if end subroutine var_list_get_cptr module subroutine var_list_get_aptr (var_list, name, aptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name type(pdg_array_t), pointer, intent(out) :: aptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_PDG) if (associated (var)) then aptr => var_entry_get_aval_ptr (var) if (present (known)) known => var_entry_get_known_ptr (var) else aptr => null () if (present (known)) known => null () end if end subroutine var_list_get_aptr module subroutine var_list_get_pptr (var_list, name, pptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name type(subevt_t), pointer, intent(out) :: pptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_SEV) if (associated (var)) then pptr => var_entry_get_pval_ptr (var) if (present (known)) known => var_entry_get_known_ptr (var) else pptr => null () if (present (known)) known => null () end if end subroutine var_list_get_pptr module subroutine var_list_get_sptr (var_list, name, sptr, known) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name type(string_t), pointer, intent(out) :: sptr logical, pointer, intent(out), optional :: known type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_STR) if (associated (var)) then sptr => var_entry_get_sval_ptr (var) if (present (known)) known => var_entry_get_known_ptr (var) else sptr => null () if (present (known)) known => null () end if end subroutine var_list_get_sptr @ %def var_list_get_lptr @ %def var_list_get_iptr @ %def var_list_get_rptr @ %def var_list_get_cptr @ %def var_list_get_aptr @ %def var_list_get_pptr @ %def var_list_get_sptr @ This bunch of methods handles the procedure-pointer cases. <>= procedure :: get_obs1_iptr => var_list_get_obs1_iptr procedure :: get_obs2_iptr => var_list_get_obs2_iptr procedure :: get_obsev_iptr => var_list_get_obsev_iptr procedure :: get_obs1_rptr => var_list_get_obs1_rptr procedure :: get_obs2_rptr => var_list_get_obs2_rptr procedure :: get_obsev_rptr => var_list_get_obsev_rptr <>= module subroutine var_list_get_obs1_iptr (var_list, name, obs1_iptr, p1) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_unary_int), pointer, intent(out) :: obs1_iptr type(prt_t), pointer, intent(out) :: p1 end subroutine var_list_get_obs1_iptr module subroutine var_list_get_obs2_iptr (var_list, name, obs2_iptr, p1, p2) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_binary_int), pointer, intent(out) :: obs2_iptr type(prt_t), pointer, intent(out) :: p1, p2 end subroutine var_list_get_obs2_iptr module subroutine var_list_get_obsev_iptr (var_list, name, obsev_iptr, pval) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_sev_int), pointer, intent(out) :: obsev_iptr type(subevt_t), pointer, intent(out) :: pval end subroutine var_list_get_obsev_iptr module subroutine var_list_get_obs1_rptr (var_list, name, obs1_rptr, p1) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_unary_real), pointer, intent(out) :: obs1_rptr type(prt_t), pointer, intent(out) :: p1 end subroutine var_list_get_obs1_rptr module subroutine var_list_get_obs2_rptr (var_list, name, obs2_rptr, p1, p2) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_binary_real), pointer, intent(out) :: obs2_rptr type(prt_t), pointer, intent(out) :: p1, p2 end subroutine var_list_get_obs2_rptr module subroutine var_list_get_obsev_rptr (var_list, name, obsev_rptr, pval) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_sev_real), pointer, intent(out) :: obsev_rptr type(subevt_t), pointer, intent(out) :: pval end subroutine var_list_get_obsev_rptr <>= module subroutine var_list_get_obs1_iptr (var_list, name, obs1_iptr, p1) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_unary_int), pointer, intent(out) :: obs1_iptr type(prt_t), pointer, intent(out) :: p1 type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_OBS1_INT) if (associated (var)) then call var_entry_assign_obs1_int_ptr (obs1_iptr, var) p1 => var_entry_get_prt1_ptr (var) else obs1_iptr => null () p1 => null () end if end subroutine var_list_get_obs1_iptr module subroutine var_list_get_obs2_iptr (var_list, name, obs2_iptr, p1, p2) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_binary_int), pointer, intent(out) :: obs2_iptr type(prt_t), pointer, intent(out) :: p1, p2 type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_OBS2_INT) if (associated (var)) then call var_entry_assign_obs2_int_ptr (obs2_iptr, var) p1 => var_entry_get_prt1_ptr (var) p2 => var_entry_get_prt2_ptr (var) else obs2_iptr => null () p1 => null () p2 => null () end if end subroutine var_list_get_obs2_iptr module subroutine var_list_get_obsev_iptr (var_list, name, obsev_iptr, pval) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_sev_int), pointer, intent(out) :: obsev_iptr type(subevt_t), pointer, intent(out) :: pval type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_OBSEV_INT) if (associated (var)) then call var_entry_assign_obsev_int_ptr (obsev_iptr, var) pval => var_entry_get_pval_ptr (var) else obsev_iptr => null () pval => null () end if end subroutine var_list_get_obsev_iptr module subroutine var_list_get_obs1_rptr (var_list, name, obs1_rptr, p1) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_unary_real), pointer, intent(out) :: obs1_rptr type(prt_t), pointer, intent(out) :: p1 type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_OBS1_REAL) if (associated (var)) then call var_entry_assign_obs1_real_ptr (obs1_rptr, var) p1 => var_entry_get_prt1_ptr (var) else obs1_rptr => null () p1 => null () end if end subroutine var_list_get_obs1_rptr module subroutine var_list_get_obs2_rptr (var_list, name, obs2_rptr, p1, p2) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_binary_real), pointer, intent(out) :: obs2_rptr type(prt_t), pointer, intent(out) :: p1, p2 type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_OBS2_REAL) if (associated (var)) then call var_entry_assign_obs2_real_ptr (obs2_rptr, var) p1 => var_entry_get_prt1_ptr (var) p2 => var_entry_get_prt2_ptr (var) else obs2_rptr => null () p1 => null () p2 => null () end if end subroutine var_list_get_obs2_rptr module subroutine var_list_get_obsev_rptr (var_list, name, obsev_rptr, pval) class(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: name procedure(obs_sev_real), pointer, intent(out) :: obsev_rptr type(subevt_t), pointer, intent(out) :: pval type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_OBSEV_REAL) if (associated (var)) then call var_entry_assign_obsev_real_ptr (obsev_rptr, var) pval => var_entry_get_pval_ptr (var) else obsev_rptr => null () pval => null () end if end subroutine var_list_get_obsev_rptr @ %def var_list_get_obs1_iptr @ %def var_list_get_obs2_iptr @ %def var_list_get_obsev_iptr @ %def var_list_get_obs1_rptr @ %def var_list_get_obs2_rptr @ %def var_list_get_obsev_rptr @ \subsection{Process Result Variables} These variables are associated to process (integration) runs and their results. Their names contain brackets (so they look like function evaluations), therefore we need to special-case them. <>= procedure :: set_procvar_int => var_list_set_procvar_int procedure :: set_procvar_real => var_list_set_procvar_real <>= module subroutine var_list_set_procvar_int (var_list, proc_id, name, ival) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: proc_id type(string_t), intent(in) :: name integer, intent(in), optional :: ival end subroutine var_list_set_procvar_int module subroutine var_list_set_procvar_real (var_list, proc_id, name, rval) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: proc_id type(string_t), intent(in) :: name real(default), intent(in), optional :: rval end subroutine var_list_set_procvar_real <>= module subroutine var_list_set_procvar_int (var_list, proc_id, name, ival) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: proc_id type(string_t), intent(in) :: name integer, intent(in), optional :: ival type(string_t) :: var_name type(var_entry_t), pointer :: var var_name = name // "(" // proc_id // ")" var => var_list_get_var_ptr (var_list, var_name) if (.not. associated (var)) then call var_list%append_int (var_name, ival, intrinsic=.true.) else if (present (ival)) then call var_list%set_int (var_name, ival, is_known=.true.) end if end subroutine var_list_set_procvar_int module subroutine var_list_set_procvar_real (var_list, proc_id, name, rval) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: proc_id type(string_t), intent(in) :: name real(default), intent(in), optional :: rval type(string_t) :: var_name type(var_entry_t), pointer :: var var_name = name // "(" // proc_id // ")" var => var_list_get_var_ptr (var_list, var_name) if (.not. associated (var)) then call var_list%append_real (var_name, rval, intrinsic=.true.) else if (present (rval)) then call var_list%set_real (var_name, rval, is_known=.true.) end if end subroutine var_list_set_procvar_real @ %def var_list_set_procvar_int @ %def var_list_set_procvar_real @ \subsection{Observable initialization} Observables are formally treated as variables, which however are evaluated each time the observable is used. The arguments (pointers) to evaluate and the function are part of the variable-list entry. <>= procedure :: append_obs1_iptr => var_list_append_obs1_iptr procedure :: append_obs2_iptr => var_list_append_obs2_iptr procedure :: append_obs1_rptr => var_list_append_obs1_rptr procedure :: append_obs2_rptr => var_list_append_obs2_rptr procedure :: append_obsev_iptr => var_list_append_obsev_iptr procedure :: append_obsev_rptr => var_list_append_obsev_rptr <>= module subroutine var_list_append_obs1_iptr & (var_list, name, obs1_iptr, p1) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_unary_int) :: obs1_iptr type(prt_t), intent(in), target :: p1 end subroutine var_list_append_obs1_iptr module subroutine var_list_append_obs2_iptr & (var_list, name, obs2_iptr, p1, p2) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_binary_int) :: obs2_iptr type(prt_t), intent(in), target :: p1, p2 end subroutine var_list_append_obs2_iptr module subroutine var_list_append_obsev_iptr & (var_list, name, obsev_iptr, sev) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_sev_int) :: obsev_iptr type(subevt_t), intent(in), target :: sev end subroutine var_list_append_obsev_iptr module subroutine var_list_append_obs1_rptr & (var_list, name, obs1_rptr, p1) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_unary_real) :: obs1_rptr type(prt_t), intent(in), target :: p1 end subroutine var_list_append_obs1_rptr module subroutine var_list_append_obs2_rptr & (var_list, name, obs2_rptr, p1, p2) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_binary_real) :: obs2_rptr type(prt_t), intent(in), target :: p1, p2 end subroutine var_list_append_obs2_rptr module subroutine var_list_append_obsev_rptr & (var_list, name, obsev_rptr, sev) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_sev_real) :: obsev_rptr type(subevt_t), intent(in), target :: sev end subroutine var_list_append_obsev_rptr <>= module subroutine var_list_append_obs1_iptr & (var_list, name, obs1_iptr, p1) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_unary_int) :: obs1_iptr type(prt_t), intent(in), target :: p1 type(var_entry_t), pointer :: var allocate (var) call var_entry_init_obs (var, name, V_OBS1_INT, p1) var%obs1_int => obs1_iptr call var_list_append (var_list, var) end subroutine var_list_append_obs1_iptr module subroutine var_list_append_obs2_iptr & (var_list, name, obs2_iptr, p1, p2) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_binary_int) :: obs2_iptr type(prt_t), intent(in), target :: p1, p2 type(var_entry_t), pointer :: var allocate (var) call var_entry_init_obs (var, name, V_OBS2_INT, p1, p2) var%obs2_int => obs2_iptr call var_list_append (var_list, var) end subroutine var_list_append_obs2_iptr module subroutine var_list_append_obsev_iptr & (var_list, name, obsev_iptr, sev) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_sev_int) :: obsev_iptr type(subevt_t), intent(in), target :: sev type(var_entry_t), pointer :: var allocate (var) call var_entry_init_obs_sev (var, name, V_OBSEV_INT, sev) var%obsev_int => obsev_iptr call var_list_append (var_list, var) end subroutine var_list_append_obsev_iptr module subroutine var_list_append_obs1_rptr & (var_list, name, obs1_rptr, p1) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_unary_real) :: obs1_rptr type(prt_t), intent(in), target :: p1 type(var_entry_t), pointer :: var allocate (var) call var_entry_init_obs (var, name, V_OBS1_REAL, p1) var%obs1_real => obs1_rptr call var_list_append (var_list, var) end subroutine var_list_append_obs1_rptr module subroutine var_list_append_obs2_rptr & (var_list, name, obs2_rptr, p1, p2) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_binary_real) :: obs2_rptr type(prt_t), intent(in), target :: p1, p2 type(var_entry_t), pointer :: var allocate (var) call var_entry_init_obs (var, name, V_OBS2_REAL, p1, p2) var%obs2_real => obs2_rptr call var_list_append (var_list, var) end subroutine var_list_append_obs2_rptr module subroutine var_list_append_obsev_rptr & (var_list, name, obsev_rptr, sev) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name procedure(obs_sev_real) :: obsev_rptr type(subevt_t), intent(in), target :: sev type(var_entry_t), pointer :: var allocate (var) call var_entry_init_obs_sev (var, name, V_OBSEV_REAL, sev) var%obsev_real => obsev_rptr call var_list_append (var_list, var) end subroutine var_list_append_obsev_rptr @ %def var_list_append_obs1_iptr @ %def var_list_append_obs2_iptr @ %def var_list_append_obs1_rptr @ %def var_list_append_obs2_rptr @ User observables: no pointer needs to be stored. <>= procedure :: append_uobs_int => var_list_append_uobs_int procedure :: append_uobs_real => var_list_append_uobs_real <>= module subroutine var_list_append_uobs_int (var_list, name, p1, p2) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(prt_t), intent(in), target :: p1 type(prt_t), intent(in), target, optional :: p2 end subroutine var_list_append_uobs_int module subroutine var_list_append_uobs_real (var_list, name, p1, p2) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(prt_t), intent(in), target :: p1 type(prt_t), intent(in), target, optional :: p2 end subroutine var_list_append_uobs_real <>= module subroutine var_list_append_uobs_int (var_list, name, p1, p2) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(prt_t), intent(in), target :: p1 type(prt_t), intent(in), target, optional :: p2 type(var_entry_t), pointer :: var allocate (var) if (present (p2)) then call var_entry_init_obs (var, name, V_UOBS2_INT, p1, p2) else call var_entry_init_obs (var, name, V_UOBS1_INT, p1) end if call var_list_append (var_list, var) end subroutine var_list_append_uobs_int module subroutine var_list_append_uobs_real (var_list, name, p1, p2) class(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: name type(prt_t), intent(in), target :: p1 type(prt_t), intent(in), target, optional :: p2 type(var_entry_t), pointer :: var allocate (var) if (present (p2)) then call var_entry_init_obs (var, name, V_UOBS2_REAL, p1, p2) else call var_entry_init_obs (var, name, V_UOBS1_REAL, p1) end if call var_list_append (var_list, var) end subroutine var_list_append_uobs_real @ %def var_list_append_uobs_int @ %def var_list_append_uobs_real @ \subsection{API for variable lists} Set a new value. If the variable holds a pointer, this pointer is followed, e.g., a model parameter is actually set. If [[ignore]] is set, do nothing if the variable does not exist. If [[verbose]] is set, echo the new value. Clear a variable (all variables), i.e., undefine the value. <>= procedure :: unset => var_list_clear <>= module subroutine var_list_clear (vars, name, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name logical, intent(in), optional :: follow_link end subroutine var_list_clear <>= module subroutine var_list_clear (vars, name, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then call var_entry_clear (var) end if end subroutine var_list_clear @ %def var_list_clear @ Setting the value, concise specific versions (implementing deferred TBP): <>= procedure :: set_ival => var_list_set_ival procedure :: set_rval => var_list_set_rval procedure :: set_cval => var_list_set_cval procedure :: set_lval => var_list_set_lval procedure :: set_sval => var_list_set_sval <>= module subroutine var_list_set_ival (vars, name, ival, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name integer, intent(in) :: ival logical, intent(in), optional :: follow_link end subroutine var_list_set_ival module subroutine var_list_set_rval (vars, name, rval, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name real(default), intent(in) :: rval logical, intent(in), optional :: follow_link end subroutine var_list_set_rval module subroutine var_list_set_cval (vars, name, cval, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name complex(default), intent(in) :: cval logical, intent(in), optional :: follow_link end subroutine var_list_set_cval module subroutine var_list_set_lval (vars, name, lval, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name logical, intent(in) :: lval logical, intent(in), optional :: follow_link end subroutine var_list_set_lval module subroutine var_list_set_sval (vars, name, sval, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name type(string_t), intent(in) :: sval logical, intent(in), optional :: follow_link end subroutine var_list_set_sval <>= module subroutine var_list_set_ival (vars, name, ival, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name integer, intent(in) :: ival logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then call var_entry_set_int (var, ival, is_known=.true.) end if end subroutine var_list_set_ival module subroutine var_list_set_rval (vars, name, rval, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name real(default), intent(in) :: rval logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then call var_entry_set_real (var, rval, is_known=.true.) end if end subroutine var_list_set_rval module subroutine var_list_set_cval (vars, name, cval, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name complex(default), intent(in) :: cval logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then call var_entry_set_cmplx (var, cval, is_known=.true.) end if end subroutine var_list_set_cval module subroutine var_list_set_lval (vars, name, lval, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name logical, intent(in) :: lval logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then call var_entry_set_log (var, lval, is_known=.true.) end if end subroutine var_list_set_lval module subroutine var_list_set_sval (vars, name, sval, follow_link) class(var_list_t), intent(inout) :: vars type(string_t), intent(in) :: name type(string_t), intent(in) :: sval logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var var => var_list_get_var_ptr (vars, name, follow_link=follow_link) if (associated (var)) then call var_entry_set_string (var, sval, is_known=.true.) end if end subroutine var_list_set_sval @ %def var_list_set_ival @ %def var_list_set_rval @ %def var_list_set_cval @ %def var_list_set_lval @ %def var_list_set_sval @ Setting the value, verbose specific versions (as subroutines): <>= procedure :: set_log => var_list_set_log procedure :: set_int => var_list_set_int procedure :: set_real => var_list_set_real procedure :: set_cmplx => var_list_set_cmplx procedure :: set_subevt => var_list_set_subevt procedure :: set_pdg_array => var_list_set_pdg_array procedure :: set_string => var_list_set_string <>= module subroutine var_list_set_log & (var_list, name, lval, is_known, ignore, force, verbose, model_name) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name logical, intent(in) :: lval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose type(string_t), intent(in), optional :: model_name end subroutine var_list_set_log module subroutine var_list_set_int & (var_list, name, ival, is_known, ignore, force, verbose, model_name) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name integer, intent(in) :: ival logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose type(string_t), intent(in), optional :: model_name end subroutine var_list_set_int module subroutine var_list_set_real & (var_list, name, rval, is_known, ignore, force, & verbose, model_name, pacified) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name real(default), intent(in) :: rval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose, pacified type(string_t), intent(in), optional :: model_name end subroutine var_list_set_real module subroutine var_list_set_cmplx & (var_list, name, cval, is_known, ignore, force, & verbose, model_name, pacified) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name complex(default), intent(in) :: cval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose, pacified type(string_t), intent(in), optional :: model_name end subroutine var_list_set_cmplx module subroutine var_list_set_pdg_array & (var_list, name, aval, is_known, ignore, force, verbose, model_name) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name type(pdg_array_t), intent(in) :: aval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose type(string_t), intent(in), optional :: model_name end subroutine var_list_set_pdg_array module subroutine var_list_set_subevt & (var_list, name, pval, is_known, ignore, force, verbose, model_name) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name type(subevt_t), intent(in) :: pval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose type(string_t), intent(in), optional :: model_name end subroutine var_list_set_subevt module subroutine var_list_set_string & (var_list, name, sval, is_known, ignore, force, verbose, model_name) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name type(string_t), intent(in) :: sval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose type(string_t), intent(in), optional :: model_name end subroutine var_list_set_string <>= module subroutine var_list_set_log & (var_list, name, lval, is_known, ignore, force, verbose, model_name) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name logical, intent(in) :: lval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose type(string_t), intent(in), optional :: model_name type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_LOG) if (associated (var)) then if (.not. var_entry_is_locked (var, force)) then select case (var%type) case (V_LOG) call var_entry_set_log (var, lval, is_known, verbose, model_name) case default call var_mismatch_error (name) end select else call var_locked_error (name) end if else call var_missing_error (name, ignore) end if end subroutine var_list_set_log module subroutine var_list_set_int & (var_list, name, ival, is_known, ignore, force, verbose, model_name) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name integer, intent(in) :: ival logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose type(string_t), intent(in), optional :: model_name type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_INT) if (associated (var)) then if (.not. var_entry_is_locked (var, force)) then select case (var%type) case (V_INT) call var_entry_set_int (var, ival, is_known, verbose, model_name) case default call var_mismatch_error (name) end select else call var_locked_error (name) end if else call var_missing_error (name, ignore) end if end subroutine var_list_set_int module subroutine var_list_set_real & (var_list, name, rval, is_known, ignore, force, & verbose, model_name, pacified) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name real(default), intent(in) :: rval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose, pacified type(string_t), intent(in), optional :: model_name type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_REAL) if (associated (var)) then if (.not. var_entry_is_locked (var, force)) then select case (var%type) case (V_REAL) call var_entry_set_real & (var, rval, is_known, verbose, model_name, pacified) case default call var_mismatch_error (name) end select else call var_locked_error (name) end if else call var_missing_error (name, ignore) end if end subroutine var_list_set_real module subroutine var_list_set_cmplx & (var_list, name, cval, is_known, ignore, force, & verbose, model_name, pacified) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name complex(default), intent(in) :: cval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose, pacified type(string_t), intent(in), optional :: model_name type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_CMPLX) if (associated (var)) then if (.not. var_entry_is_locked (var, force)) then select case (var%type) case (V_CMPLX) call var_entry_set_cmplx & (var, cval, is_known, verbose, model_name, pacified) case default call var_mismatch_error (name) end select else call var_locked_error (name) end if else call var_missing_error (name, ignore) end if end subroutine var_list_set_cmplx module subroutine var_list_set_pdg_array & (var_list, name, aval, is_known, ignore, force, verbose, model_name) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name type(pdg_array_t), intent(in) :: aval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose type(string_t), intent(in), optional :: model_name type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_PDG) if (associated (var)) then if (.not. var_entry_is_locked (var, force)) then select case (var%type) case (V_PDG) call var_entry_set_pdg_array & (var, aval, is_known, verbose, model_name) case default call var_mismatch_error (name) end select else call var_locked_error (name) end if else call var_missing_error (name, ignore) end if end subroutine var_list_set_pdg_array module subroutine var_list_set_subevt & (var_list, name, pval, is_known, ignore, force, verbose, model_name) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name type(subevt_t), intent(in) :: pval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose type(string_t), intent(in), optional :: model_name type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_SEV) if (associated (var)) then if (.not. var_entry_is_locked (var, force)) then select case (var%type) case (V_SEV) call var_entry_set_subevt & (var, pval, is_known, verbose, model_name) case default call var_mismatch_error (name) end select else call var_locked_error (name) end if else call var_missing_error (name, ignore) end if end subroutine var_list_set_subevt module subroutine var_list_set_string & (var_list, name, sval, is_known, ignore, force, verbose, model_name) class(var_list_t), intent(inout), target :: var_list type(string_t), intent(in) :: name type(string_t), intent(in) :: sval logical, intent(in) :: is_known logical, intent(in), optional :: ignore, force, verbose type(string_t), intent(in), optional :: model_name type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name, V_STR) if (associated (var)) then if (.not. var_entry_is_locked (var, force)) then select case (var%type) case (V_STR) call var_entry_set_string & (var, sval, is_known, verbose, model_name) case default call var_mismatch_error (name) end select else call var_locked_error (name) end if else call var_missing_error (name, ignore) end if end subroutine var_list_set_string subroutine var_mismatch_error (name) type(string_t), intent(in) :: name call msg_fatal ("Type mismatch for variable '" // char (name) // "'") end subroutine var_mismatch_error subroutine var_locked_error (name) type(string_t), intent(in) :: name call msg_error ("Variable '" // char (name) // "' is not user-definable") end subroutine var_locked_error subroutine var_missing_error (name, ignore) type(string_t), intent(in) :: name logical, intent(in), optional :: ignore logical :: error if (present (ignore)) then error = .not. ignore else error = .true. end if if (error) then call msg_fatal ("Variable '" // char (name) // "' has not been declared") end if end subroutine var_missing_error @ %def var_list_set_log @ %def var_list_set_int @ %def var_list_set_real @ %def var_list_set_cmplx @ %def var_list_set_subevt @ %def var_list_set_pdg_array @ %def var_list_set_string @ %def var_mismatch_error @ %def var_missing_error @ Import values for the current variable list from another list. <>= procedure :: import => var_list_import <>= module subroutine var_list_import (var_list, src_list) class(var_list_t), intent(inout) :: var_list type(var_list_t), intent(in) :: src_list end subroutine var_list_import <>= module subroutine var_list_import (var_list, src_list) class(var_list_t), intent(inout) :: var_list type(var_list_t), intent(in) :: src_list type(var_entry_t), pointer :: var, src var => var_list%first do while (associated (var)) src => var_list_get_var_ptr (src_list, var%name) if (associated (src)) then call var_entry_copy_value (var, src) end if var => var%next end do end subroutine var_list_import @ %def var_list_import @ Mark all entries in the current variable list as undefined. This is done when a local variable list is discarded. If the local list is used again (by a loop), the entries will be re-initialized. <>= procedure :: undefine => var_list_undefine <>= recursive module subroutine var_list_undefine (var_list, follow_link) class(var_list_t), intent(inout) :: var_list logical, intent(in), optional :: follow_link end subroutine var_list_undefine <>= recursive module subroutine var_list_undefine (var_list, follow_link) class(var_list_t), intent(inout) :: var_list logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var logical :: rec rec = .true.; if (present (follow_link)) rec = follow_link var => var_list%first do while (associated (var)) call var_entry_undefine (var) var => var%next end do if (rec .and. associated (var_list%next)) then call var_list_undefine (var_list%next, follow_link=follow_link) end if end subroutine var_list_undefine @ %def var_list_undefine @ Make a deep copy of a variable list. <>= procedure :: init_snapshot => var_list_init_snapshot <>= recursive module subroutine var_list_init_snapshot & (var_list, vars_in, follow_link) class(var_list_t), intent(out) :: var_list type(var_list_t), intent(in) :: vars_in logical, intent(in), optional :: follow_link end subroutine var_list_init_snapshot <>= recursive module subroutine var_list_init_snapshot & (var_list, vars_in, follow_link) class(var_list_t), intent(out) :: var_list type(var_list_t), intent(in) :: vars_in logical, intent(in), optional :: follow_link type(var_entry_t), pointer :: var, var_in type(var_list_t), pointer :: var_list_next logical :: rec rec = .true.; if (present (follow_link)) rec = follow_link var_in => vars_in%first do while (associated (var_in)) allocate (var) call var_entry_init_copy (var, var_in) call var_entry_copy_value (var, var_in) call var_list_append (var_list, var) var_in => var_in%next end do if (rec .and. associated (vars_in%next)) then allocate (var_list_next) call var_list_init_snapshot (var_list_next, vars_in%next) call var_list%link (var_list_next) end if end subroutine var_list_init_snapshot @ %def var_list_init_snapshot @ Check if a user variable can be set. The [[new]] flag is set if the user variable has an explicit declaration. If an error occurs, return [[V_NONE]] as variable type. Also determine the actual type of generic numerical variables, which enter the procedure with type [[V_NONE]]. <>= procedure :: check_user_var => var_list_check_user_var <>= module subroutine var_list_check_user_var (var_list, name, type, new) class(var_list_t), intent(in), target :: var_list type(string_t), intent(in) :: name integer, intent(inout) :: type logical, intent(in) :: new end subroutine var_list_check_user_var <>= module subroutine var_list_check_user_var (var_list, name, type, new) class(var_list_t), intent(in), target :: var_list type(string_t), intent(in) :: name integer, intent(inout) :: type logical, intent(in) :: new type(var_entry_t), pointer :: var var => var_list_get_var_ptr (var_list, name) if (associated (var)) then if (type == V_NONE) then type = var_entry_get_type (var) end if if (var_entry_is_locked (var)) then call msg_fatal ("Variable '" // char (name) & // "' is not user-definable") type = V_NONE return else if (new) then if (var_entry_is_intrinsic (var)) then call msg_fatal ("Intrinsic variable '" & // char (name) // "' redeclared") type = V_NONE return end if if (var_entry_get_type (var) /= type) then call msg_fatal ("Variable '" // char (name) // "' " & // "redeclared with different type") type = V_NONE return end if end if end if end subroutine var_list_check_user_var @ %def var_list_check_user_var @ \subsection{Default values for global var list} <>= procedure :: init_defaults => var_list_init_defaults <>= module subroutine var_list_init_defaults (var_list, seed, paths) class(var_list_t), intent(out) :: var_list integer, intent(in) :: seed type(paths_t), intent(in), optional :: paths end subroutine var_list_init_defaults <>= module subroutine var_list_init_defaults (var_list, seed, paths) class(var_list_t), intent(out) :: var_list integer, intent(in) :: seed type(paths_t), intent(in), optional :: paths call var_list%set_beams_defaults (paths) call var_list%set_core_defaults (seed) call var_list%set_integration_defaults () call var_list%set_phase_space_defaults () call var_list%set_gamelan_defaults () call var_list%set_clustering_defaults () call var_list%set_isolation_recomb_defaults () call var_list%set_eio_defaults () call var_list%set_shower_defaults () call var_list%set_hadronization_defaults () call var_list%set_tauola_defaults () call var_list%set_mlm_matching_defaults () call var_list%set_powheg_matching_defaults () call var_list%append_log (var_str ("?ckkw_matching"), .false., & intrinsic=.true., description=var_str ('Master flag that switches ' // & 'on the CKKW(-L) (LO) matching between hard scattering matrix ' // & 'elements and QCD parton showers. Note that this is not yet ' // & '(completely) implemented in \whizard. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...})')) call var_list%set_openmp_defaults () call var_list%set_mpi_defaults () call var_list%set_nlo_defaults () end subroutine var_list_init_defaults @ %def var_list_init_defaults @ <>= procedure :: set_beams_defaults => var_list_set_beams_defaults <>= module subroutine var_list_set_beams_defaults (var_list, paths) type(paths_t), intent(in), optional :: paths class(var_list_t), intent(inout) :: var_list end subroutine var_list_set_beams_defaults <>= module subroutine var_list_set_beams_defaults (var_list, paths) type(paths_t), intent(in), optional :: paths class(var_list_t), intent(inout) :: var_list call var_list%append_real (var_str ("sqrts"), & intrinsic=.true., & description=var_str ('Real variable in order to set the center-of-mass ' // & 'energy for the collisions (collider energy $\sqrt{s}$, not ' // & 'hard interaction energy $\sqrt{\hat{s}}$): \ttt{sqrts = {\em ' // & '} [ {\em } ]}. The physical unit can be one ' // & 'of the following \ttt{eV}, \ttt{keV}, \ttt{MeV}, \ttt{GeV}, ' // & 'and \ttt{TeV}. If absent, \whizard\ takes \ttt{GeV} as its ' // & 'standard unit. Note that this variable is absolutely mandatory ' // & 'for integration and simulation of scattering processes.')) call var_list%append_real (var_str ("luminosity"), 0._default, & intrinsic=.true., & description=var_str ('This specifier \ttt{luminosity = {\em ' // & '}} sets the integrated luminosity (in inverse femtobarns, ' // & 'fb${}^{-1}$) for the event generation of the processes in the ' // & '\sindarin\ input files. Note that WHIZARD itself chooses the ' // & 'number from the \ttt{luminosity} or from the \ttt{n\_events} ' // & 'specifier, whichever would give the larger number of events. ' // & 'As this depends on the cross section under consideration, it ' // & 'might be different for different processes in the process list. ' // & '(cf. \ttt{n\_events}, \ttt{\$sample}, \ttt{sample\_format}, \ttt{?unweighted})')) call var_list%append_log (var_str ("?sf_trace"), .false., & intrinsic=.true., & description=var_str ('Debug flag that writes out detailed information ' // & 'about the structure function setup into the file \ttt{{\em ' // & '}\_sftrace.dat}. This file name can be changed ' // & 'with ($\to$) \ttt{\$sf\_trace\_file}.')) call var_list%append_string (var_str ("$sf_trace_file"), var_str (""), & intrinsic=.true., & description=var_str ('\ttt{\$sf\_trace\_file = "{\em }"} ' // & 'allows to change the detailed structure function information ' // & 'switched on by the debug flag ($\to$) \ttt{?sf\_trace} into ' // & 'a different file \ttt{{\em }} than the default ' // & '\ttt{{\em }\_sftrace.dat}.')) call var_list%append_log (var_str ("?sf_allow_s_mapping"), .true., & intrinsic=.true., & description=var_str ('Flag that determines whether special mappings ' // & 'for processes with structure functions and $s$-channel resonances ' // & 'are applied, e.g. Drell-Yan at hadron colliders, or $Z$ production ' // & 'at linear colliders with beamstrahlung and ISR.')) if (present (paths)) then call var_list%append_string (var_str ("$lhapdf_dir"), paths%lhapdfdir, & intrinsic=.true., & description=var_str ('String variable that tells the path ' // & 'where the \lhapdf\ library and PDF sets can be found. When ' // & 'the library has been correctly recognized during configuration, ' // & 'this is automatically set by \whizard. (cf. also \ttt{lhapdf}, ' // & '\ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, ' // & '\ttt{lhapdf\_member}, \ttt{lhapdf\_photon\_scheme})')) else call var_list%append_string (var_str ("$lhapdf_dir"), var_str(""), & intrinsic=.true., & description=var_str ('String variable that tells the path ' // & 'where the \lhapdf\ library and PDF sets can be found. When ' // & 'the library has been correctly recognized during configuration, ' // & 'this is automatically set by \whizard. (cf. also \ttt{lhapdf}, ' // & '\ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, ' // & '\ttt{lhapdf\_member}, \ttt{lhapdf\_photon\_scheme})')) end if call var_list%append_string (var_str ("$lhapdf_file"), var_str (""), & intrinsic=.true., & description=var_str ('This string variable \ttt{\$lhapdf\_file ' // & '= "{\em }"} allows to specify the PDF set \ttt{{\em ' // & '}} from the external \lhapdf\ library. It must match ' // & 'the exact name of the PDF set from the \lhapdf\ library. The ' // & 'default is empty, and the default set from \lhapdf\ is taken. ' // & 'Only one argument is possible, the PDF set must be identical ' // & 'for both beams, unless there are fundamentally different beam ' // & 'particles like proton and photon. (cf. also \ttt{lhapdf}, \ttt{\$lhapdf\_dir}, ' // & '\ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, \ttt{lhapdf\_photon\_scheme}, ' // & '\ttt{lhapdf\_member})')) call var_list%append_string (var_str ("$lhapdf_photon_file"), var_str (""), & intrinsic=.true., & description=var_str ('String variable \ttt{\$lhapdf\_photon\_file ' // & '= "{\em }"} analagous to ($\to$) \ttt{\$lhapdf\_file} ' // & 'for photon PDF structure functions from the external \lhapdf\ ' // & 'library. The name must exactly match the one of the set from ' // & '\lhapdf. (cf. \ttt{beams}, \ttt{lhapdf}, \ttt{\$lhapdf\_dir}, ' // & '\ttt{\$lhapdf\_file}, \ttt{\$lhapdf\_photon\_file}, \ttt{lhapdf\_member}, ' // & '\ttt{lhapdf\_photon\_scheme})')) call var_list%append_int (var_str ("lhapdf_member"), 0, & intrinsic=.true., & description=var_str ('Integer variable that specifies the number ' // & 'of the corresponding PDF set chosen via the command ($\to$) ' // & '\ttt{\$lhapdf\_file} or ($\to$) \ttt{\$lhapdf\_photon\_file} ' // & 'from the external \lhapdf\ library. E.g. error PDF sets can ' // & 'be chosen by this. (cf. also \ttt{lhapdf}, \ttt{\$lhapdf\_dir}, ' // & '\ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, ' // & '\ttt{lhapdf\_photon\_scheme})')) call var_list%append_int (var_str ("lhapdf_photon_scheme"), 0, & intrinsic=.true., & description=var_str ('Integer parameter that controls the different ' // & 'available schemes for photon PDFs inside the external \lhapdf\ ' // & 'library. For more details see the \lhapdf\ manual. (cf. also ' // & '\ttt{lhapdf}, \ttt{\$lhapdf\_dir}, \ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, ' // & '\ttt{\$lhapdf\_photon\_file}, \ttt{lhapdf\_member})')) call var_list%append_string (var_str ("$pdf_builtin_set"), var_str ("CTEQ6L"), & intrinsic=.true., & description=var_str ("For \whizard's internal PDF structure functions " // & 'for hadron colliders, this string variable allows to set the ' // & 'particular PDF set. (cf. also \ttt{pdf\_builtin}, \ttt{pdf\_builtin\_photon})')) call var_list%append_log (var_str ("?hoppet_b_matching"), .false., & intrinsic=.true., & description=var_str ('Flag that switches on the matching between ' // & '4- and 5-flavor schemes for hadron collider $b$-parton initiated ' // & 'processes. Works either with builtin PDFs or with the external ' // & '\lhapdf\ interface. Needs the external \ttt{HOPPET} library ' // & 'to be linked. (cf. \ttt{beams}, \ttt{pdf\_builtin}, \ttt{lhapdf})')) call var_list%append_real (var_str ("isr_alpha"), 0._default, & intrinsic=.true., & description=var_str ('For lepton collider initial-state QED ' // & 'radiation (ISR), this real parameter sets the value of $\alpha_{em}$ ' // & 'used in the structure function. If not set, it is taken from ' // & 'the parameter set of the physics model in use (cf. also \ttt{isr}, ' // & '\ttt{isr\_q\_max}, \ttt{isr\_mass}, \ttt{isr\_order}, \ttt{?isr\_recoil}, ' // & '\ttt{?isr\_keep\_energy})')) call var_list%append_real (var_str ("isr_q_max"), 0._default, & intrinsic=.true., & description=var_str ('This real parameter allows to set the ' // & 'scale of the initial-state QED radiation (ISR) structure function. ' // & 'If not set, it is taken internally to be $\sqrt{s}$. (cf. ' // & 'also \ttt{isr}, \ttt{isr\_alpha}, \ttt{isr\_mass}, \ttt{isr\_order}, ' // & '\ttt{?isr\_recoil}, \ttt{?isr\_keep\_energy})')) call var_list%append_real (var_str ("isr_mass"), 0._default, & intrinsic=.true., & description=var_str ('This real parameter allows to set by hand ' // & 'the mass of the incoming particle for lepton collider initial-state ' // & 'QED radiation (ISR). If not set, the mass for the initial beam ' // & 'particle is taken from the model in use. (cf. also \ttt{isr}, ' // & '\ttt{isr\_q\_max}, \ttt{isr\_alpha}, \ttt{isr\_order}, \ttt{?isr\_recoil}, ' // & - '\ttt{?isr\_keep\_energy})')) + '\ttt{?isr\_keep\_energy}, \ttt{isr\_log\_order})')) call var_list%append_int (var_str ("isr_order"), 3, & intrinsic=.true., & description=var_str ('For lepton collider initial-state QED ' // & 'radiation (ISR), this integer parameter allows to set the order ' // & 'up to which hard-collinear radiation is taken into account. ' // & 'Default is the highest available, namely third order. (cf. ' // & 'also \ttt{isr}, \ttt{isr\_q\_max}, \ttt{isr\_mass}, \ttt{isr\_alpha}, ' // & - '\ttt{?isr\_recoil}, \ttt{?isr\_keep\_energy})')) + '\ttt{?isr\_recoil}, \ttt{?isr\_keep\_energy}, \ttt{isr\_log\_order})')) + call var_list%append_int (var_str ("isr_log_order"), 0, & + intrinsic=.true., & + description=var_str ('For lepton collider initial-state QED ' // & + 'radiation (ISR), this integer parameters sets the logarithmic ' // & + 'order: 0 (default) is LL, 1 is NLL. (cf. ' // & + 'also \ttt{isr}, \ttt{isr\_q\_max}, \ttt{isr\_mass}, \ttt{isr\_alpha}, ' // & + '\ttt{?isr\_recoil}, \ttt{?isr\_keep\_energy}, \ttt{isr\_order})')) + call var_list%append_real (var_str ("isr_q_in"), -1._default, & + intrinsic=.true., & + description=var_str ('This is the starting scale for the running ' // & + 'of the QED coupling alpha. If negative, the electron mass is taken. ' // & + '(cf. also \ttt{isr}, ' // & + '\ttt{isr\_q\_max}, \ttt{isr\_alpha}, \ttt{isr\_order}, \ttt{?isr\_recoil}, ' // & + '\ttt{?isr\_keep\_energy}, \ttt{isr\_log\_order})')) call var_list%append_log (var_str ("?isr_recoil"), .false., & intrinsic=.true., & description=var_str ('Flag to switch on recoil, i.e. a non-vanishing ' // & '$p_T$-kick for the lepton collider initial-state QED radiation ' // & '(ISR). (cf. also \ttt{isr}, \ttt{isr}, \ttt{isr\_alpha}, \ttt{isr\_mass}, ' // & - '\ttt{isr\_order}, \ttt{isr\_q\_max})')) + '\ttt{isr\_order}, \ttt{isr\_q\_max}, \ttt{isr\_log\_order})')) call var_list%append_log (var_str ("?isr_keep_energy"), .false., & intrinsic=.true., & description=var_str ('As the splitting kinematics for the ISR ' // & 'structure function violates Lorentz invariance when the recoil ' // & 'is switched on, this flag forces energy conservation when set ' // & 'to true, otherwise violating energy conservation. (cf. also ' // & '\ttt{isr}, \ttt{isr\_q\_max}, \ttt{isr\_mass}, \ttt{isr\_order}, ' // & '\ttt{?isr\_recoil}, \ttt{?isr\_alpha})')) call var_list%append_log (var_str ("?isr_handler"), .false., & intrinsic=.true., & description=var_str ('Activate ISR ' // & 'handler for event generation (no effect on integration). ' // & 'Requires \ttt{isr\_recoil = false}')) call var_list%append_string (var_str ("$isr_handler_mode"), & var_str ("trivial"), & intrinsic=.true., & description=var_str ('Operation mode for the ISR ' // & 'event handler. Allowed values: \ttt{trivial} (no effect), ' // & '\ttt{recoil} (recoil kinematics with two photons)')) call var_list%append_log (var_str ("?isr_handler_keep_mass"), .true., & intrinsic=.true., & description=var_str ('If \ttt{true} (default), force the incoming ' // & 'partons of the hard process (after radiation) on their mass ' // & 'shell. Otherwise, insert massless on-shell momenta. This ' // & 'applies only for event generation (no effect on integration, ' // & 'cf.\ also \ttt{?isr\_handler})')) call var_list%append_string (var_str ("$epa_mode"), & var_str ("default"), intrinsic=.true., & description=var_str ('For the equivalent photon approximation ' // & '(EPA), this string variable defines the mode, i.e. the explicit ' // & 'formula for the EPA distribution. For more details cf. the manual. ' // & 'Possible are \ttt{default} (\ttt{Budnev\_617}), \ttt{Budnev\_616e}, ' // & '\ttt{log\_power}, \ttt{log\_simple}, and \ttt{log}. ' // & '(cf. also \ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_e\_max}, ' // & '\ttt{epa\_q\_min}, \ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, ' // & '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_real (var_str ("epa_alpha"), 0._default, & intrinsic=.true., & description=var_str ('For the equivalent photon approximation ' // & '(EPA), this real parameter sets the value of $\alpha_{em}$ ' // & 'used in the structure function. If not set, it is taken from ' // & 'the parameter set of the physics model in use (cf. also \ttt{epa}, ' // & '\ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_e\_max}, \ttt{epa\_q\_min}, ' // & '\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}, ' // & '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_real (var_str ("epa_x_min"), 0._default, & intrinsic=.true., & description=var_str ('Real parameter that sets the lower cutoff ' // & 'for the energy fraction in the splitting for the equivalent-photon ' // & 'approximation (EPA). This parameter has to be set by the user ' // & 'to a non-zero value smaller than one. (cf. also \ttt{epa}, ' // & '\ttt{epa\_e\_max}, \ttt{epa\_mass}, \ttt{epa\_alpha}, \ttt{epa\_q\_min}, ' // & '\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}, ' // & '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_real (var_str ("epa_q_min"), 0._default, & intrinsic=.true., & description=var_str ('In the equivalent-photon approximation ' // & '(EPA), this real parameters sets the minimal value for the ' // & 'transferred momentum. Either this parameter or the mass of ' // & 'the beam particle has to be non-zero. (cf. also \ttt{epa}, ' // & '\ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_alpha}, \ttt{epa\_q\_max}, ' // & '\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}, ' // & '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_real (var_str ("epa_q_max"), 0._default, & intrinsic=.true., & description=var_str ('This real parameter allows to set the ' // & 'upper energy cutoff for the equivalent-photon approximation ' // & '(EPA). If not set, \whizard\ simply takes the collider energy, ' // & '$\sqrt{s}$. (cf. also \ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, ' // & '\ttt{epa\_alpha}, \ttt{epa\_q\_min}, \ttt{?epa\_recoil}, \ttt{\$epa\_mode}, ' // & '\ttt{?epa\_keep\_energy}, \ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_real (var_str ("epa_mass"), 0._default, & intrinsic=.true., & description=var_str ('This real parameter allows to set by hand ' // & 'the mass of the incoming particle for the equivalent-photon ' // & 'approximation (EPA). If not set, the mass for the initial beam ' // & 'particle is taken from the model in use. (cf. also \ttt{epa}, ' // & '\ttt{epa\_x\_min}, \ttt{epa\_e\_max}, \ttt{epa\_alpha}, \ttt{epa\_q\_min}, ' // & '\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}. ' // & '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_log (var_str ("?epa_recoil"), .false., & intrinsic=.true., & description=var_str ('Flag to switch on recoil, i.e. a non-vanishing ' // & '$p_T$-kick for the equivalent-photon approximation (EPA). ' // & '(cf. also \ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_alpha}, ' // & '\ttt{epa\_e\_max}, \ttt{epa\_q\_min}, \ttt{?epa\_keep\_energy}, ' // & '\ttt{\$epa\_mode}, \ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_log (var_str ("?epa_keep_energy"), .false., & intrinsic=.true., & description=var_str ('As the splitting kinematics for the EPA ' // & 'structure function violates Lorentz invariance when the recoil ' // & 'is switched on, this flag forces energy conservation when set ' // & 'to true, otherwise violating energy conservation. (cf. also ' // & '\ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_alpha}, ' // & '\ttt{epa\_q\_min}, \ttt{?epa\_recoil}, \ttt{\$epa\_mode}, ' // & '\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})')) call var_list%append_log (var_str ("?epa_handler"), .false., & intrinsic=.true., & description=var_str ('Activate EPA ' // & 'handler for event generation (no effect on integration). ' // & 'Requires \ttt{epa\_recoil = false}')) call var_list%append_string (var_str ("$epa_handler_mode"), & var_str ("trivial"), & intrinsic=.true., & description=var_str ('Operation mode for the EPA ' // & 'event handler. Allowed values: \ttt{trivial} (no effect), ' // & '\ttt{recoil} (recoil kinematics with two beams)')) call var_list%append_real (var_str ("ewa_x_min"), 0._default, & intrinsic=.true., & description=var_str ('Real parameter that sets the lower cutoff ' // & 'for the energy fraction in the splitting for the equivalent ' // & '$W$ approximation (EWA). This parameter has to be set by the ' // & 'user to a non-zero value smaller than one. (cf. also \ttt{ewa}, ' // & '\ttt{ewa\_pt\_max}, \ttt{ewa\_mass}, \ttt{?ewa\_keep\_energy}, ' // & '\ttt{?ewa\_recoil})')) call var_list%append_real (var_str ("ewa_pt_max"), 0._default, & intrinsic=.true., & description=var_str ('This real parameter allows to set the ' // & 'upper $p_T$ cutoff for the equivalent $W$ approximation (EWA). ' // & 'If not set, \whizard\ simply takes the collider energy, $\sqrt{s}$. ' // & '(cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, \ttt{ewa\_mass}, \ttt{?ewa\_keep\_energy}, ' // & '\ttt{?ewa\_recoil})')) call var_list%append_real (var_str ("ewa_mass"), 0._default, & intrinsic=.true., & description=var_str ('This real parameter allows to set by hand ' // & 'the mass of the incoming particle for the equivalent $W$ approximation ' // & '(EWA). If not set, the mass for the initial beam particle is ' // & 'taken from the model in use. (cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, ' // & '\ttt{ewa\_pt\_max}, \ttt{?ewa\_keep\_energy}, \ttt{?ewa\_recoil})')) call var_list%append_log (var_str ("?ewa_recoil"), .false., & intrinsic=.true., & description=var_str ('For the equivalent $W$ approximation (EWA), ' // & 'this flag switches on recoil, i.e. non-collinear splitting. ' // & '(cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, \ttt{ewa\_pt\_max}, ' // & '\ttt{ewa\_mass}, \ttt{?ewa\_keep\_energy})')) call var_list%append_log (var_str ("?ewa_keep_energy"), .false., & intrinsic=.true., & description=var_str ('As the splitting kinematics for the equivalent ' // & '$W$ approximation (EWA) violates Lorentz invariance when the ' // & 'recoil is switched on, this flag forces energy conservation ' // & 'when set to true, otherwise violating energy conservation. ' // & '(cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, \ttt{ewa\_pt\_max}, ' // & '\ttt{ewa\_mass}, \ttt{?ewa\_recoil})')) call var_list%append_log (var_str ("?circe1_photon1"), .false., & intrinsic=.true., & description=var_str ('Flag to tell \whizard\ to use the photon ' // & 'of the \circeone\ beamstrahlung structure function as initiator ' // & 'for the hard scattering process in the first beam. (cf. also ' // & '\ttt{circe1}, \ttt{?circe1\_photon2}, \ttt{circe1\_sqrts}, ' // & '\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // & '\newline \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // & '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline' // & '\ttt{?circe1\_with\_radiation})')) call var_list%append_log (var_str ("?circe1_photon2"), .false., & intrinsic=.true., & description=var_str ('Flag to tell \whizard\ to use the photon ' // & 'of the \circeone\ beamstrahlung structure function as initiator ' // & 'for the hard scattering process in the second beam. (cf. also ' // & '\ttt{circe1}, \ttt{?circe1\_photon1}, \ttt{circe1\_sqrts}, ' // & '\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // & '\newline \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // & '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, ' // & '\newline\ttt{?circe1\_with\_radiation})')) call var_list%append_real (var_str ("circe1_sqrts"), & intrinsic=.true., & description=var_str ('Real parameter that allows to set the ' // & 'value of the collider energy for the lepton collider beamstrahlung ' // & 'structure function \circeone. If not set, $\sqrt{s}$ is taken. ' // & '(cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, \ttt{?circe1\_photon2}, ' // & '\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // & '\newline \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // & '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline' // & '\ttt{?circe1\_with\_radiation})')) call var_list%append_log (var_str ("?circe1_generate"), .true., & intrinsic=.true., & description=var_str ('Flag that determines whether the \circeone\ ' // & 'structure function for lepton collider beamstrahlung uses the ' // & 'generator mode for the spectrum, or a pre-defined (semi-)analytical ' // & 'parameterization. Default is the generator mode. (cf. also ' // & '\ttt{circe1}, \ttt{?circe1\_photon1}, \newline \ttt{?circe1\_photon2}, ' // & '\ttt{circe1\_sqrts}, \ttt{?circe1\_map}, \ttt{circe1\_mapping\_slope}, ' // & '\ttt{circe1\_eps}, \newline \ttt{circe1\_ver}, \ttt{circe1\_rev}, ' // & '\ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})')) call var_list%append_log (var_str ("?circe1_map"), .true., & intrinsic=.true., & description=var_str ('Flag that determines whether the \circeone\ ' // & 'structure function for lepton collider beamstrahlung uses special ' // & 'mappings for $s$-channel resonances. (cf. also \ttt{circe1}, ' // & '\ttt{?circe1\_photon1}, \newline \ttt{?circe1\_photon2}, ' // & '\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, ' // & '\ttt{circe1\_mapping\_slope}, \ttt{circe1\_eps}, \newline ' // & '\ttt{circe1\_ver}, \ttt{circe1\_rev}, \ttt{\$circe1\_acc}, ' // & '\ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})')) call var_list%append_real (var_str ("circe1_mapping_slope"), 2._default, & intrinsic=.true., & description=var_str ('Real parameter that allows to vary the ' // & 'slope of the mapping function for the \circeone\ structure ' // & 'function for lepton collider beamstrahlung from the default ' // & 'value \ttt{2.}. (cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, ' // & '\ttt{?circe1\_photon2}, \ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, ' // & '\ttt{?circe1\_map}, \ttt{circe1\_eps}, \ttt{circe1\_ver}, ' // & '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline' // & '\ttt{?circe1\_with\_radiation})')) call var_list%append_real (var_str ("circe1_eps"), 1e-5_default, & intrinsic=.true., & description=var_str ('Real parameter, that takes care of the ' // & 'mapping of the peak in the lepton collider beamstrahlung structure ' // & 'function spectrum of \circeone. (cf. also \ttt{circe1}, \ttt{?circe1\_photons}, ' // & '\ttt{?circe1\_photon2}, \ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, ' // & '\ttt{?circe1\_map}, \ttt{circe1\_eps}, \newline ' // & '\ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, \ttt{circe1\_rev}, ' // & '\ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline\ttt{?circe1\_with\_radiation})')) call var_list%append_int (var_str ("circe1_ver"), 0, intrinsic=.true., & description=var_str ('Integer parameter that sets the internal ' // & 'versioning number of the \circeone\ structure function for lepton-collider ' // & 'beamstrahlung. It has to be set by the user explicitly, it takes ' // & 'values from one to ten. (cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, ' // & '\ttt{?circe1\_photon2}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // & '\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_sqrts}, ' // & '\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, ' // & '\ttt{?circe1\_with\_radiation})')) call var_list%append_int (var_str ("circe1_rev"), 0, intrinsic=.true., & description=var_str ('Integer parameter that sets the internal ' // & 'revision number of the \circeone\ structure function for lepton-collider ' // & 'beamstrahlung. The default \ttt{0} translates always into the ' // & 'most recent version; older versions have to be accessed through ' // & 'the explicit revision date. For more details cf.~the \circeone ' // & 'manual. (cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, \ttt{?circe1\_photon2}, ' // & '\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // & '\ttt{circe1\_mapping\_slope}, \ttt{circe1\_sqrts}, \ttt{circe1\_ver}, ' // & '\ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})')) call var_list%append_string (var_str ("$circe1_acc"), var_str ("SBAND"), & intrinsic=.true., & description=var_str ('String variable that specifies the accelerator ' // & 'type for the \circeone\ structure function for lepton-collider ' // & 'beamstrahlung. (\ttt{?circe1\_photons}, \ttt{?circe1\_photon2}, ' // & '\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // & '\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // & '\newline \ttt{circe1\_rev}, \ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})')) call var_list%append_int (var_str ("circe1_chat"), 0, intrinsic=.true., & description=var_str ('Chattiness of the \circeone\ structure ' // & 'function for lepton-collider beamstrahlung. The higher the integer ' // & 'value, the more information will be given out by the \circeone\ ' // & 'package. (\ttt{?circe1\_photons}, \ttt{?circe1\_photon2}, ' // & '\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // & '\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // & '\newline \ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{?circe1\_with\_radiation})')) call var_list%append_log (var_str ("?circe1_with_radiation"), .false., & intrinsic=.true., & description=var_str ('This logical decides whether the additional photon ' // & 'or electron ("beam remnant") will be considered in the event record or ' // & 'not. (\ttt{?circe1\_photons}, \ttt{?circe1\_photon2}, ' // & '\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // & '\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // & '\newline \ttt{circe1\_rev}, \ttt{\$circe1\_acc})')) call var_list%append_log (var_str ("?circe2_polarized"), .true., & intrinsic=.true., & description=var_str ('Flag whether the photon spectra from the ' // & '\circetwo\ structure function for lepton colliders should be ' // & 'treated polarized. (cf. also \ttt{circe2}, \ttt{\$circe2\_file}, ' // & '\ttt{\$circe2\_design})')) call var_list%append_string (var_str ("$circe2_file"), & intrinsic=.true., & description=var_str ('String variable by which the corresponding ' // & 'photon collider spectrum for the \circetwo\ structure function ' // & 'can be selected. (cf. also \ttt{circe2}, \ttt{?circe2\_polarized}, ' // & '\ttt{\$circe2\_design})')) call var_list%append_string (var_str ("$circe2_design"), var_str ("*"), & intrinsic=.true., & description=var_str ('String variable that sets the collider ' // & 'design for the \circetwo\ structure function for photon collider ' // & 'spectra. (cf. also \ttt{circe2}, \ttt{\$circe2\_file}, \ttt{?circe2\_polarized})')) call var_list%append_real (var_str ("gaussian_spread1"), 0._default, & intrinsic=.true., & description=var_str ('Parameter that sets the energy spread ' // & '($\sigma$ value) of the first beam for a Gaussian spectrum. ' // & '(cf. \ttt{gaussian})')) call var_list%append_real (var_str ("gaussian_spread2"), 0._default, & intrinsic=.true., & description=var_str ('Ditto, for the second beam.')) call var_list%append_string (var_str ("$beam_events_file"), & intrinsic=.true., & description=var_str ('String variable that allows to set the ' // & "name of the external file from which a beamstrahlung's spectrum " // & 'for lepton colliders as pairs of energy fractions is read in. ' // & '(cf. also \ttt{beam\_events}, \ttt{?beam\_events\_warn\_eof})')) call var_list%append_log (var_str ("?beam_events_warn_eof"), .true., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to ' // & 'issue a warning when in a simulation the end of an external ' // & "file for beamstrahlung's spectra for lepton colliders are reached, " // & 'and energy fractions from the beginning of the file are reused. ' // & '(cf. also \ttt{beam\_events}, \ttt{\$beam\_events\_file})')) call var_list%append_log (var_str ("?energy_scan_normalize"), .false., & intrinsic=.true., & description=var_str ('Normalization flag for the energy scan ' // & 'structure function: if set the total cross section is normalized ' // & 'to unity. (cf. also \ttt{energy\_scan})')) call var_list%append_string (var_str ("$negative_sf"), var_str ("default"), & intrinsic=.true., & description=var_str ('String variable to set the behavior to either ' // & 'keep negative structure function/PDF values or set them to zero. ' // & 'The default (\ttt{"default"}) takes the first option for NLO and the ' // & 'second for LO processes. Explicit behavior can be set with ' // & '\ttt{"positive"} or \ttt{"negative"}.')) end subroutine var_list_set_beams_defaults @ %def var_list_set_beams_defaults @ <>= procedure :: set_core_defaults => var_list_set_core_defaults <>= module subroutine var_list_set_core_defaults (var_list, seed) class(var_list_t), intent(inout) :: var_list integer, intent(in) :: seed end subroutine var_list_set_core_defaults <>= module subroutine var_list_set_core_defaults (var_list, seed) class(var_list_t), intent(inout) :: var_list integer, intent(in) :: seed logical, target, save :: known = .true. !!! ?????? real(default), parameter :: real_specimen = 1. call var_list_append_log_ptr & (var_list, var_str ("?logging"), logging, known, & intrinsic=.true., & description=var_str ('This logical -- when set to \ttt{false} ' // & '-- suppresses writing out a logfile (default: \ttt{whizard.log}) ' // & 'for the whole \whizard\ run, or when \whizard\ is run with the ' // & '\ttt{--no-logging} option, to suppress parts of the logging ' // & 'when setting it to \ttt{true} again at a later part of the ' // & '\sindarin\ input file. Mainly for debugging purposes. ' // & '(cf. also \ttt{?openmp\_logging}, \ttt{?mpi\_logging})')) call var_list%append_string (var_str ("$job_id"), & intrinsic=.true., & description=var_str ('Arbitrary string that can be used for ' // & 'creating unique names. The variable is initialized with the ' // & 'value of the \ttt{job\_id} option on startup. (cf. also ' // & '\ttt{\$compile\_workspace}, \ttt{\$run\_id})')) call var_list%append_string (var_str ("$compile_workspace"), & intrinsic=.true., & description=var_str ('If set, create process source code ' // & 'and process-driver library code in a subdirectory with this ' // & 'name. If non-existent, the directory will be created. (cf. ' // & 'also \ttt{\$job\_id}, \ttt{\$run\_id}, \ttt{\$integrate\_workspace})')) call var_list%append_int (var_str ("seed"), seed, & intrinsic=.true., & description=var_str ('Integer variable \ttt{seed = {\em }} ' // & 'that allows to set a specific random seed \ttt{num}. If not ' // & 'set, \whizard\ takes the time from the system clock to determine ' // & 'the random seed.')) call var_list%append_string (var_str ("$model_name"), & intrinsic=.true., & description=var_str ('This variable makes the locally used physics ' // & 'model available as a string, e.g. as \ttt{show (\$model\_name)}. ' // & 'However, the user is not able to change the current model by ' // & 'setting this variable to a different string. (cf. also \ttt{model}, ' // & '\ttt{\$library\_name}, \ttt{printf}, \ttt{show})')) call var_list%append_int (var_str ("process_num_id"), & intrinsic=.true., & description=var_str ('Using the integer \ttt{process\_num\_id ' // & '= {\em }} one can set a numerical identifier for processes ' // & 'within a process library. This can be set either just before ' // & 'the corresponding \ttt{process} definition or as an optional ' // & 'local argument of the latter. (cf. also \ttt{process}, ' // & '\ttt{?proc\_as\_run\_id}, \ttt{lcio\_run\_id})')) call var_list%append_log (var_str ("?proc_as_run_id"), .true., & intrinsic=.true., & description=var_str ('Normally, for LCIO the process ID (cf. ' // & '\ttt{process\_num\_id}) is used as run ID, unless this flag is ' // & 'set to \ttt{false}, cf. also \ttt{process}, \ttt{lcio\_run\_id}.')) call var_list%append_int (var_str ("lcio_run_id"), 0, & intrinsic=.true., & description=var_str ('Allows to set an integer run ID for the LCIO ' // & 'event format. Normally, the process ID is taken as run ID, unless ' // & 'the flag (cf.) \ttt{?proc\_as\_run\_id} is set to \ttt{false}, ' // & 'cf. also \ttt{process}.')) call var_list%append_string (var_str ("$method"), var_str ("omega"), & intrinsic=.true., & description=var_str ('This string variable specifies the method ' // & 'for the matrix elements to be used in the evaluation. The default ' // & "is the intrinsic \oMega\ matrix element generator " // & '(\ttt{"omega"}), other options are: \ttt{"ovm"}, \ttt{"unit\_test"}, ' // & '\ttt{"template\_unity"}, \ttt{"threshold"}. For processes defined ' // & '\ttt{"template"}, with \ttt{nlo\_calculation = ...}, please refer to ' // & '\ttt{\$born\_me\_method}, \ttt{\$real\_tree\_me\_method}, ' // & '\ttt{\$loop\_me\_method} and \ttt{\$correlation\_me\_method}.')) call var_list%append_log (var_str ("?report_progress"), .true., & intrinsic=.true., & description=var_str ('Flag for the \oMega\ matrix element generator ' // & 'whether to print out status messages about progress during ' // & 'matrix element generation. (cf. also \ttt{\$method}, \ttt{\$omega\_flags})')) call var_list%append_log (var_str ("?me_verbose"), .false., & description=var_str ("Flag determining whether " // & "the makefile command for generating and compiling the \oMega\ matrix " // & "element code is silent or verbose. Default is silent.")) call var_list%append_string (var_str ("$restrictions"), var_str (""), & intrinsic=.true., & description=var_str ('This is an optional argument for process ' // & 'definitions for the matrix element method \ttt{"omega"}. Using ' // & 'the following construction, it defines a string variable, \ttt{process ' // & '\newline {\em } = {\em }, {\em } ' // & '=> {\em }, {\em }, ... \{ \$restrictions ' // & '= "{\em }" \}}. The string argument \ttt{{\em ' // & '}} is directly transferred during the code ' // & 'generation to the ME generator \oMega. It has to be of the form ' // & '\ttt{n1 + n2 + ... \url{~} {\em }}, where ' // & '\ttt{n1} and so on are the numbers of the particles above in ' // & 'the process definition. The tilde specifies a certain intermediate ' // & 'state to be equal to the particle(s) in \ttt{particle (list)}. ' // & 'An example is \ttt{process eemm\_z = e1, E1 => e2, E2 ' // & '\{ \$restrictions = "1+2 \url{~} Z" \} } restricts the code ' // & 'to be generated for the process $e^- e^+ \to \mu^- \mu^+$ to ' // & 'the $s$-channel $Z$-boson exchange. For more details see Sec.~\ref{sec:omega_me} ' // & '(cf. also \ttt{process})')) call var_list%append_log (var_str ("?omega_write_phs_output"), .false., & intrinsic=.true., & description=var_str ('This flag decides whether a the phase-space ' // & 'output is produced by the \oMega\ matrix element generator. This ' // & 'output is written to file(s) and contains the Feynman diagrams ' // & 'which belong to the process(es) under consideration. The file is ' // & 'mandatory whenever the variable \ttt{\$phs\_method} has the value ' // & '\ttt{fast\_wood}, i.e. if the phase-space file is provided by ' // & 'cascades2.')) call var_list%append_string (var_str ("$omega_flags"), var_str (""), & intrinsic=.true., & description=var_str ('String variable that allows to pass flags ' // & 'to the \oMega\ matrix element generator. Normally, \whizard\ ' // & 'takes care of all flags automatically. Note that for restrictions ' // & 'of intermediate states, there is a special string variable: ' // & '(cf. $\to$) \ttt{\$restrictions}.')) call var_list%append_log (var_str ("?read_color_factors"), .true., & intrinsic=.true., & description=var_str ('This flag decides whether to read QCD ' // & 'color factors from the matrix element provided by each method, ' // & 'or to try and calculate the color factors in \whizard\ internally.')) call var_list%append_log (var_str ("?slha_read_input"), .true., & intrinsic=.true., & description=var_str ('Flag which decides whether \whizard\ reads ' // & 'in the SM and parameter information from the \ttt{SMINPUTS} ' // & 'and \ttt{MINPAR} common blocks of the SUSY Les Houches Accord ' // & 'files. (cf. also \ttt{read\_slha}, \ttt{write\_slha}, \ttt{?slha\_read\_spectrum}, ' // & '\ttt{?slha\_read\_decays})')) call var_list%append_log (var_str ("?slha_read_spectrum"), .true., & intrinsic=.true., & description=var_str ('Flag which decides whether \whizard\ reads ' // & 'in the whole spectrum and mixing angle information from the ' // & 'common blocks of the SUSY Les Houches Accord files. (cf. also ' // & '\ttt{read\_slha}, \ttt{write\_slha}, \ttt{?slha\_read\_decays}, ' // & '\ttt{?slha\_read\_input})')) call var_list%append_log (var_str ("?slha_read_decays"), .false., & intrinsic=.true., & description=var_str ('Flag which decides whether \whizard\ reads ' // & 'in the widths and branching ratios from the \ttt{DCINFO} common ' // & 'block of the SUSY Les Houches Accord files. (cf. also \ttt{read\_slha}, ' // & '\ttt{write\_slha}, \ttt{?slha\_read\_spectrum}, \ttt{?slha\_read\_input})')) call var_list%append_string (var_str ("$library_name"), & intrinsic=.true., & description=var_str ('Similar to \ttt{\$model\_name}, this string ' // & 'variable is used solely to access the name of the active process ' // & 'library, e.g. in \ttt{printf} statements. (cf. \ttt{compile}, ' // & '\ttt{library}, \ttt{printf}, \ttt{show}, \ttt{\$model\_name})')) call var_list%append_log (var_str ("?alphas_is_fixed"), .true., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to use a non-running ' // & 'QCD $\alpha_s$. Note that this has to be set explicitly to $\ttt{false}$ ' // & 'if the user wants to use one of the running $\alpha_s$ options. ' // & '(cf. also \ttt{alphas\_order}, \ttt{?alphas\_from\_lhapdf}, ' // & '\ttt{?alphas\_from\_pdf\_builtin}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, ' // & '\newline \ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})')) call var_list%append_log (var_str ("?alpha_is_fixed"), .true., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to use a non-running ' // & 'QED $\alpha$. Note that this has to be set explicitly to $\ttt{false}$ ' // & 'if the user wants to use one of the running $\alpha$ options. ' // & '(cf. also \ttt{alpha\_order}, \ttt{alpha\_nf}, \ttt{alpha\_lep}, ' // & '\ttt{?alphas\_from\_me}')) call var_list%append_log (var_str ("?alphas_from_lhapdf"), .false., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to use a running ' // & '$\alpha_s$ from the \lhapdf\ library (which has to be correctly ' // & 'linked). Note that \ttt{?alphas\_is\_fixed} has to be set ' // & 'explicitly to $\ttt{false}$. (cf. also \ttt{alphas\_order}, ' // & '\ttt{?alphas\_is\_fixed}, \ttt{?alphas\_from\_pdf\_builtin}, ' // & '\ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, \ttt{?alphas\_from\_lambda\_qcd}, ' // & '\ttt{lambda\_qcd})')) call var_list%append_log (var_str ("?alphas_from_pdf_builtin"), .false., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to use a running ' // & '$\alpha_s$ from the internal PDFs. Note that in that case \ttt{?alphas\_is\_fixed} ' // & 'has to be set explicitly to $\ttt{false}$. (cf. also ' // & '\ttt{alphas\_order}, \ttt{?alphas\_is\_fixed}, \ttt{?alphas\_from\_lhapdf}, ' // & '\ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, \newline \ttt{?alphas\_from\_lambda\_qcd}, ' // & '\ttt{lambda\_qcd})')) call var_list%append_log (var_str ("?alpha_evolve_analytic"), .true., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to use analytic running ' // & 'formulae for $\alpha$ instead of a numeric Runge-Kutta. ' // & '(cf. also \ttt{alpha\_order}, \ttt{?alpha\_is\_fixed}, ' // & '\ttt{alpha\_nf}, \ttt{alpha\_nlep}, \ttt{?alpha\_from\_me}) ')) call var_list%append_int (var_str ("alphas_order"), 0, & intrinsic=.true., & description=var_str ('Integer parameter that sets the order ' // & 'of the internal evolution for running $\alpha_s$ in \whizard: ' // & 'the default, \ttt{0}, is LO running, \ttt{1} is NLO, \ttt{2} ' // & 'is NNLO. (cf. also \ttt{alphas\_is\_fixed}, \ttt{?alphas\_from\_lhapdf}, ' // & '\ttt{?alphas\_from\_pdf\_builtin}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, ' // & '\newline \ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})')) call var_list%append_int (var_str ("alpha_order"), 0, & intrinsic=.true., & description=var_str ('Integer parameter that sets the order ' // & 'of the internal evolution for running $\alpha$ in \whizard: ' // & 'the default, \ttt{0}, is LO running, \ttt{1} is NLO. ' // & '(cf. also \ttt{alpha\_is\_fixed}, \ttt{alpha\_nf}, \ttt{alphas\_lep}, ' // & '\ttt{?alpha\_from\_me})')) call var_list%append_int (var_str ("alphas_nf"), 5, & intrinsic=.true., & description=var_str ('Integer parameter that sets the number ' // & 'of active quark flavors for the internal evolution for running ' // & '$\alpha_s$ in \whizard. (cf. also ' // & '\ttt{alphas\_is\_fixed}, \ttt{?alphas\_from\_lhapdf}, \ttt{?alphas\_from\_pdf\_builtin}, ' // & '\ttt{alphas\_order}, \ttt{?alphas\_from\_mz}, \newline ' // & '\ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})')) call var_list%append_int (var_str ("alpha_nf"), -1, & intrinsic=.true., & description=var_str ('Integer parameter that sets the number ' // & 'of active quark flavors for the internal evolution for running ' // & '$\alpha$ in \whizard. The default, \ttt{-1}, keeps it equal to \ttt{alphas\_nf} ' // & '\ttt{alpha\_is\_fixed}, \ttt{alphas\_order}, \ttt{?alpha\_from\_me}, ' // & '\ttt{?alpha\_evolve\_analytic}')) call var_list%append_int (var_str ("alpha_nlep"), 1, & intrinsic=.true., & description=var_str ('Integer parameter that sets the number ' // & 'of active leptons in the running of $\alpha$ in \whizard. The deffault is' // & 'one, with only the electron considered massless (cf. also ' // & '\ttt{alpha\_is\_fixed}, \ttt{alpha\_nf}, ' // & '\ttt{alpha\_order}, \ttt{?alpha\_from\_me}, \ttt{?alpha\_evolve\_analytic})')) call var_list%append_log (var_str ("?alphas_from_mz"), .false., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to use its internal ' // & 'running $\alpha_s$ from $\alpha_s(M_Z)$. Note that in that ' // & 'case \ttt{?alphas\_is\_fixed} has to be set explicitly to ' // & '$\ttt{false}$. (cf. also \ttt{alphas\_order}, \ttt{?alphas\_is\_fixed}, ' // & '\ttt{?alphas\_from\_lhapdf}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_pdf\_builtin}, ' // & '\newline \ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})')) call var_list%append_log (var_str ("?alphas_from_lambda_qcd"), .false., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to use its internal ' // & 'running $\alpha_s$ from $\alpha_s(\Lambda_{QCD})$. Note that ' // & 'in that case \ttt{?alphas\_is\_fixed} has to be set explicitly ' // & 'to $\ttt{false}$. (cf. also \ttt{alphas\_order}, \ttt{?alphas\_is\_fixed}, ' // & '\ttt{?alphas\_from\_lhapdf}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_pdf\_builtin}, ' // & '\newline \ttt{?alphas\_from\_mz}, \ttt{lambda\_qcd})')) call var_list%append_real (var_str ("lambda_qcd"), 200.e-3_default, & intrinsic=.true., & description=var_str ('Real parameter that sets the value for ' // & '$\Lambda_{QCD}$ used in the internal evolution for running ' // & '$\alpha_s$ in \whizard. (cf. also \ttt{alphas\_is\_fixed}, ' // & '\ttt{?alphas\_from\_lhapdf}, \ttt{alphas\_nf}, ' // & '\newline \ttt{?alphas\_from\_pdf\_builtin}, ' // & '\ttt{?alphas\_from\_mz}, \ttt{?alphas\_from\_lambda\_qcd}, ' // & '\ttt{alphas\_order})')) call var_list%append_log (var_str ("?fatal_beam_decay"), .true., & intrinsic=.true., & description=var_str ('Logical variable that let the user decide ' // & 'whether the possibility of a beam decay is treated as a fatal ' // & 'error or only as a warning. An example is a process $b t \to ' // & 'X$, where the bottom quark as an inital state particle appears ' // & 'as a possible decay product of the second incoming particle, ' // & 'the top quark. This might trigger inconsistencies or instabilities ' // & 'in the phase space set-up.')) call var_list%append_log (var_str ("?helicity_selection_active"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether \whizard\ uses ' // & 'a numerical selection rule for vanishing helicities: if active, ' // & 'then, if a certain helicity combination yields an absolute ' // & '(\oMega) matrix element smaller than a certain threshold ($\to$ ' // & '\ttt{helicity\_selection\_threshold}) more often than a certain ' // & 'cutoff ($\to$ \ttt{helicity\_selection\_cutoff}), it will be dropped.')) call var_list%append_real (var_str ("helicity_selection_threshold"), & 1E10_default, & intrinsic=.true., & description=var_str ('Real parameter that gives the threshold ' // & 'for the absolute value of a certain helicity combination of ' // & 'an (\oMega) amplitude. If a certain number ($\to$ ' // & '\ttt{helicity\_selection\_cutoff}) of calls stays below this ' // & 'threshold, that combination will be dropped from then on. (cf. ' // & 'also \ttt{?helicity\_selection\_active})')) call var_list%append_int (var_str ("helicity_selection_cutoff"), 1000, & intrinsic=.true., & description=var_str ('Integer parameter that gives the number ' // & "a certain helicity combination of an (\oMega) amplitude has " // & 'to be below a certain threshold ($\to$ \ttt{helicity\_selection\_threshold}) ' // & 'in order to be dropped from then on. (cf. also \ttt{?helicity\_selection\_active})')) call var_list%append_string (var_str ("$rng_method"), var_str ("tao"), & intrinsic=.true., & description=var_str ('String variable that allows to set the ' // & 'method for the random number generation. Default is Donald ' // & "Knuth' RNG method \ttt{TAO}.")) call var_list%append_log (var_str ("?vis_diags"), .false., & intrinsic=.true., & description=var_str ('Logical variable that allows to give out ' // & "a Postscript or PDF file for the Feynman diagrams for a \oMega\ " // & 'process. (cf. \ttt{?vis\_diags\_color}).')) call var_list%append_log (var_str ("?vis_diags_color"), .false., & intrinsic=.true., & description=var_str ('Same as \ttt{?vis\_diags}, but switches ' // & 'on color flow instead of Feynman diagram generation. (cf. \ttt{?vis\_diags}).')) call var_list%append_log (var_str ("?check_event_file"), .true., & intrinsic=.true., & description=var_str ('Setting this to false turns off all sanity ' // & 'checks when reading a raw event file with previously generated ' // & 'events. Use this at your own risk; the program may return ' // & 'wrong results or crash if data do not match. (cf. also \ttt{?check\_grid\_file}, ' // & '\ttt{?check\_phs\_file})')) call var_list%append_string (var_str ("$event_file_version"), var_str (""), & intrinsic=.true., & description=var_str ('String variable that allows to set the ' // & 'format version of the \whizard\ internal binary event format.')) call var_list%append_int (var_str ("n_events"), 0, & intrinsic=.true., & description=var_str ('This specifier \ttt{n\_events = {\em }} ' // & 'sets the number of events for the event generation of the processes ' // & 'in the \sindarin\ input files. Note that WHIZARD itself chooses ' // & 'the number from the \ttt{n\_events} or from the \ttt{luminosity} ' // & 'specifier, whichever would give the larger number of events. ' // & 'As this depends on the cross section under consideration, it ' // & 'might be different for different processes in the process list. ' // & '(cf. \ttt{luminosity}, \ttt{\$sample}, \ttt{sample\_format}, ' // & '\ttt{?unweighted}, \ttt{event\_index\_offset})')) call var_list%append_int (var_str ("event_index_offset"), 0, & intrinsic=.true., & description=var_str ('The value ' // & '\ttt{event\_index\_offset = {\em }} ' // & 'initializes the event counter for a subsequent ' // & 'event sample. By default (value 0), the first event ' // & 'gets index value 1, incrementing by one for each generated event ' // & 'within a sample. The event counter is initialized again ' // & 'for each new sample (i.e., \ttt{integrate} command). ' // & 'If events are read from file, and the ' // & 'event file format supports event numbering, the event numbers ' // & 'will be taken from file instead, and the value of ' // & '\ttt{event\_index\_offset} has no effect. ' // & '(cf. \ttt{luminosity}, \ttt{\$sample}, \ttt{sample\_format}, ' // & '\ttt{?unweighted}, \ttt{n\_events})')) call var_list%append_log (var_str ("?unweighted"), .true., & intrinsic=.true., & description=var_str ('Flag that distinguishes between unweighted ' // & 'and weighted event generation. (cf. also \ttt{simulate}, \ttt{n\_events}, ' // & '\ttt{luminosity}, \ttt{event\_index\_offset})')) call var_list%append_real (var_str ("safety_factor"), 1._default, & intrinsic=.true., & description=var_str ('This real variable \ttt{safety\_factor ' // & '= {\em }} reduces the acceptance probability for unweighting. ' // & 'If greater than one, excess events become less likely, but ' // & 'the reweighting efficiency also drops. (cf. \ttt{simulate}, \ttt{?unweighted})')) call var_list%append_log (var_str ("?negative_weights"), .false., & intrinsic=.true., & description=var_str ('Flag that tells \whizard\ to allow negative ' // & 'weights in integration and simulation. (cf. also \ttt{simulate}, ' // & '\ttt{?unweighted})')) call var_list%append_log (var_str ("?resonance_history"), .false., & intrinsic=.true., & description=var_str ( & 'The logical variable \texttt{?resonance\_history ' // & '= true/false} specifies whether during a simulation pass, ' // & 'the event generator should try to reconstruct intermediate ' // & 'resonances. If activated, appropriate resonant subprocess ' // & 'matrix element code will be automatically generated. ')) call var_list%append_real (var_str ("resonance_on_shell_limit"), & 4._default, & intrinsic=.true., & description=var_str ( & 'The real variable \texttt{resonance\_on\_shell\_limit ' // & '= {\em }} specifies the maximum relative distance from a ' // & 'resonance peak, such that the kinematical configuration ' // & 'can still be considered on-shell. This is relevant only if ' // & '\texttt{?resonance\_history = true}.')) call var_list%append_real (var_str ("resonance_on_shell_turnoff"), & 0._default, & intrinsic=.true., & description=var_str ( & 'The real variable \texttt{resonance\_on\_shell\_turnoff ' // & '= {\em }}, if positive, ' // & 'controls the smooth transition from resonance-like ' // & 'to background-like events. The relative strength of a ' // & 'resonance is reduced by a Gaussian with width given by this ' // & 'variable. In any case, events are treated as background-like ' // & 'when the off-shellness is greater than ' // & '\texttt{resonance\_on\_shell\_limit}. All of this applies ' // & 'only if \texttt{?resonance\_history = true}.')) call var_list%append_real (var_str ("resonance_background_factor"), & 1._default, & intrinsic=.true., & description=var_str ( & 'The real variable \texttt{resonance\_background\_factor} ' // & 'controls resonance insertion if a resonance ' // & 'history applies to a particular event. In determining '// & 'whether event kinematics qualifies as resonant or non-resonant, ' //& 'the non-resonant probability is multiplied by this factor ' // & 'Setting the factor to zero removes the background ' // & 'configuration as long as the kinematics qualifies as on-shell ' // & 'as qualified by \texttt{resonance\_on\_shell\_limit}.')) call var_list%append_log (var_str ("?keep_beams"), .false., & intrinsic=.true., & description=var_str ('The logical variable \ttt{?keep\_beams ' // & '= true/false} specifies whether beam particles and beam remnants ' // & 'are included when writing event files. For example, in order ' // & 'to read Les Houches accord event files into \pythia, no beam ' // & 'particles are allowed.')) call var_list%append_log (var_str ("?keep_remnants"), .true., & intrinsic=.true., & description=var_str ('The logical variable \ttt{?keep\_beams ' // & '= true/false} is respected only if \ttt{?keep\_beams} is set. ' // & 'If \ttt{true}, beam remnants are tagged as outgoing particles ' // & 'if they have been neither showered nor hadronized, i.e., have ' // & 'no children. If \ttt{false}, beam remnants are also included ' // & 'in the event record, but tagged as unphysical. Note that for ' // & 'ISR and/or beamstrahlung spectra, the radiated photons are ' // & 'considered as beam remnants.')) call var_list%append_log (var_str ("?rescan_force"), .false., & intrinsic=.true., & description=var_str ('Flag that allows to bypass essential ' // & 'checks on the particle set when reading event/rescanning files ' // & 'into \whizard. (cf. \ttt{rescan}, \ttt{?update\_event}, \ttt{?update\_sqme}, ' // & '\newline \ttt{?update\_weight})')) call var_list%append_log (var_str ("?recover_beams"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether the beam particles ' // & 'should be reconstructed when reading event/rescanning files ' // & 'into \whizard. (cf. \ttt{rescan}, \ttt{?update\_event}, \ttt{?update\_sqme}, ' // & '\newline \ttt{?update\_weight})')) call var_list%append_log (var_str ("?update_event"), .false., & intrinsic=.true., & description=var_str ('Flag that decides whether the events in ' // & 'an event file should be rebuilt from the hard process when ' // & 'reading event/rescanning files into \whizard. (cf. \ttt{rescan}, ' // & '\ttt{?recover\_beams}, \ttt{?update\_sqme}, \ttt{?update\_weight})')) call var_list%append_log (var_str ("?update_sqme"), .false., & intrinsic=.true., & description=var_str ('Flag that decides whether the squared ' // & 'matrix element in an event file should be updated/recalculated ' // & 'when reading event/rescanning files into \whizard. (cf. \ttt{rescan}, ' // & '\newline \ttt{?recover\_beams}, \ttt{?update\_event}, \ttt{?update\_weight})')) call var_list%append_log (var_str ("?update_weight"), .false., & intrinsic=.true., & description=var_str ('Flag that decides whether the weights ' // & 'in an event file should be updated/recalculated when reading ' // & 'event/rescanning files into \whizard. (cf. \ttt{rescan}, \ttt{?recover\_beams}, ' // & '\newline \ttt{?update\_event}, \ttt{?update\_sqme})')) call var_list%append_log (var_str ("?use_alphas_from_file"), .false., & intrinsic=.true., & description=var_str ('Flag that decides whether the current ' // & '$\alpha_s$ definition should be used when recalculating matrix ' // & 'elements for events read from file, or the value that is stored ' // & 'in the file for that event. (cf. \ttt{rescan}, \ttt{?update\_sqme}, ' // & '\ttt{?use\_scale\_from\_file})')) call var_list%append_log (var_str ("?use_scale_from_file"), .false., & intrinsic=.true., & description=var_str ('Flag that decides whether the current ' // & 'energy-scale expression should be used when recalculating matrix ' // & 'elements for events read from file, or the value that is stored ' // & 'in the file for that event. (cf. \ttt{rescan}, \ttt{?update\_sqme}, ' // & '\ttt{?use\_alphas\_from\_file})')) call var_list%append_log (var_str ("?allow_decays"), .true., & intrinsic=.true., & description=var_str ('Master flag to switch on cascade decays ' // & 'for final state particles as an event transform. As a default, ' // & 'it is switched on. (cf. also \ttt{?auto\_decays}, ' // & '\ttt{auto\_decays\_multiplicity}, \ttt{?auto\_decays\_radiative}, ' // & '\ttt{?decay\_rest\_frame})')) call var_list%append_log (var_str ("?auto_decays"), .false., & intrinsic=.true., & description=var_str ('Flag, particularly as optional argument of the ($\to$) ' // & '\ttt{unstable} command, that tells \whizard\ to automatically ' // & 'determine the decays of that particle up to the final state ' // & 'multplicity ($\to$) \ttt{auto\_decays\_multiplicity}. Depending ' // & 'on the flag ($\to$) \ttt{?auto\_decays\_radiative}, radiative ' // & 'decays will be taken into account or not. (cf. also \ttt{unstable}, ' // & '\ttt{?isotropic\_decay}, \ttt{?diagonal\_decay})')) call var_list%append_int (var_str ("auto_decays_multiplicity"), 2, & intrinsic=.true., & description=var_str ('Integer parameter, that sets -- ' // & 'for the ($\to$) \ttt{?auto\_decays} option to let \whizard\ ' // & 'automatically determine the decays of a particle set as ($\to$) ' // & '\ttt{unstable} -- the maximal final state multiplicity that ' // & 'is taken into account. The default is \ttt{2}. The flag \ttt{?auto\_decays\_radiative} ' // & 'decides whether radiative decays are taken into account. (cf.\ ' // & 'also \ttt{unstable}, \ttt{?auto\_decays})')) call var_list%append_log (var_str ("?auto_decays_radiative"), .false., & intrinsic=.true., & description=var_str ("If \whizard's automatic detection " // & 'of decay channels are switched on ($\to$ \ttt{?auto\_decays} ' // & 'for the ($\to$) \ttt{unstable} command, this flags decides ' // & 'whether radiative decays (e.g. containing additional photon(s)/gluon(s)) ' // & 'are taken into account or not. (cf. also \ttt{unstable}, \ttt{auto\_decays\_multiplicity})')) call var_list%append_log (var_str ("?decay_rest_frame"), .false., & intrinsic=.true., & description=var_str ('Flag that allows to force a particle decay ' // & 'to be simulated in its rest frame. This simplifies the calculation ' // & 'for decays as stand-alone processes, but makes the process ' // & 'unsuitable for use in a decay chain.')) call var_list%append_log (var_str ("?isotropic_decay"), .false., & intrinsic=.true., & description=var_str ('Flag that -- in case of using factorized ' // & 'production and decays using the ($\to$) \ttt{unstable} command ' // & '-- tells \whizard\ to switch off spin correlations completely ' // & '(isotropic decay). (cf. also \ttt{unstable}, \ttt{?auto\_decays}, ' // & '\ttt{decay\_helicity}, \ttt{?diagonal\_decay})')) call var_list%append_log (var_str ("?diagonal_decay"), .false., & intrinsic=.true., & description=var_str ('Flag that -- in case of using factorized ' // & 'production and decays using the ($\to$) \ttt{unstable} command ' // & '-- tells \whizard\ instead of full spin correlations to take ' // & 'only the diagonal entries in the spin-density matrix (i.e. ' // & 'classical spin correlations). (cf. also \ttt{unstable}, \ttt{?auto\_decays}, ' // & '\ttt{decay\_helicity}, \ttt{?isotropic\_decay})')) call var_list%append_int (var_str ("decay_helicity"), & intrinsic=.true., & description=var_str ('If this parameter is given an integer ' // & 'value, any particle decay triggered by a subsequent \ttt{unstable} ' // & 'declaration will receive a projection on the given helicity ' // & 'state for the unstable particle. (cf. also \ttt{unstable}, ' // & '\ttt{?isotropic\_decay}, \ttt{?diagonal\_decay}. The latter ' // & 'parameters, if true, take precdence over any \ttt{?decay\_helicity} setting.)')) call var_list%append_log (var_str ("?polarized_events"), .false., & intrinsic=.true., & description=var_str ('Flag that allows to select certain helicity ' // & 'combinations in final state particles in the event files, ' // & 'and perform analysis on polarized event samples. (cf. also ' // & '\ttt{simulate}, \ttt{polarized}, \ttt{unpolarized})')) call var_list%append_string (var_str ("$polarization_mode"), & var_str ("helicity"), & intrinsic=.true., & description=var_str ('String variable that specifies the mode in ' // & 'which the polarization of particles is handled when polarized events ' // & 'are written out. Possible options are \ttt{"ignore"}, \ttt{"helicity"}, ' // & '\ttt{"factorized"}, and \ttt{"correlated"}. For more details cf. the ' // & 'detailed section.')) call var_list%append_log (var_str ("?colorize_subevt"), .false., & intrinsic=.true., & description=var_str ('Flag that enables color-index tracking ' // & 'in the subevent (\ttt{subevt}) objects that are used for ' // & 'internal event analysis.')) call var_list%append_real (var_str ("tolerance"), 0._default, & intrinsic=.true., & description=var_str ('Real variable that defines the absolute ' // & 'tolerance with which the (logical) function \ttt{expect} accepts ' // & 'equality or inequality: \ttt{tolerance = {\em }}. This ' // & 'can e.g. be used for cross-section tests and backwards compatibility ' // & 'checks. (cf. also \ttt{expect})')) call var_list%append_int (var_str ("checkpoint"), 0, & intrinsic = .true., & description=var_str ('Setting this integer variable to a positive ' // & 'integer $n$ instructs simulate to print out a progress summary ' // & 'every $n$ events.')) call var_list%append_int (var_str ("event_callback_interval"), 0, & intrinsic = .true., & description=var_str ('Setting this integer variable to a positive ' // & 'integer $n$ instructs simulate to print out a progress summary ' // & 'every $n$ events.')) call var_list%append_log (var_str ("?pacify"), .false., & intrinsic=.true., & description=var_str ('Flag that allows to suppress numerical ' // & 'noise and give screen and log file output with a lower number ' // & 'of significant digits. Mainly for debugging purposes. (cf. also ' // & '\ttt{?sample\_pacify})')) call var_list%append_string (var_str ("$out_file"), var_str (""), & intrinsic=.true., & description=var_str ('This character variable allows to specify ' // & 'the name of the data file to which the histogram and plot data ' // & 'are written (cf. also \ttt{write\_analysis}, \ttt{open\_out}, ' // & '\ttt{close\_out})')) call var_list%append_log (var_str ("?out_advance"), .true., & intrinsic=.true., & description=var_str ('Flag that sets advancing in the \ttt{printf} ' // & 'output commands, i.e. continuous printing with no line feed ' // & 'etc. (cf. also \ttt{printf})')) call var_list%append_int (var_str ("real_range"), & range (real_specimen), intrinsic = .true., locked = .true., & description=var_str ('This integer gives the decimal exponent ' // & 'range of the numeric model for the real float type in use. It cannot ' // & 'be set by the user. (cf. also \ttt{real\_precision}, ' // & '\ttt{real\_epsilon}, \ttt{real\_tiny}).')) call var_list%append_int (var_str ("real_precision"), & precision (real_specimen), intrinsic = .true., locked = .true., & description=var_str ('This integer gives the precision of ' // & 'the numeric model for the real float type in use. It cannot ' // & 'be set by the user. (cf. also \ttt{real\_range}, ' // & '\ttt{real\_epsilon}, \ttt{real\_tiny}).')) call var_list%append_real (var_str ("real_epsilon"), & epsilon (real_specimen), intrinsic = .true., locked = .true., & description=var_str ('This gives the smallest number $E$ ' // & 'of the same kind as the float type for which $1 + E > 1$. ' // & 'It cannot be set by the user. (cf. also \ttt{real\_range}, ' // & '\ttt{real\_tiny}, \ttt{real\_precision}).')) call var_list%append_real (var_str ("real_tiny"), & tiny (real_specimen), intrinsic = .true., locked = .true., & description=var_str ('This gives the smallest positive (non-zero) ' // & 'number in the numeric model for the real float type in use. ' // & 'It cannot be set by the user. (cf. also \ttt{real\_range}, ' // & '\ttt{real\_epsilon}, \ttt{real\_precision}).')) end subroutine var_list_set_core_defaults @ %def var_list_set_core_defaults @ <>= procedure :: set_integration_defaults => var_list_set_integration_defaults <>= module subroutine var_list_set_integration_defaults (var_list) class(var_list_t), intent(inout) :: var_list end subroutine var_list_set_integration_defaults <>= module subroutine var_list_set_integration_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_string (var_str ("$integration_method"), var_str ("vamp"), & intrinsic=.true., & description=var_str ('This string variable specifies the method ' // & 'for performing the multi-dimensional phase-space integration. ' // & 'The default is the \vamp\ algorithm (\ttt{"vamp"}), other options ' // & 'are via the numerical midpoint rule (\ttt{"midpoint"}) or an ' // & 'alternate \vamptwo\ implementation that is MPI-parallelizable ' // & '(\ttt{"vamp2"}).')) call var_list%append_int (var_str ("threshold_calls"), 10, & intrinsic=.true., & description=var_str ('This integer variable gives a limit for ' // & 'the number of calls in a given channel which acts as a lower ' // & 'threshold for the channel weight. If the number of calls in ' // & 'that channel falls below this threshold, the weight is not ' // & 'lowered further but kept at this threshold. (cf. also ' // & '\ttt{channel\_weights\_power})')) call var_list%append_int (var_str ("min_calls_per_channel"), 10, & intrinsic=.true., & description=var_str ('Integer parameter that modifies the settings ' // & "of the \vamp\ integrator's grid parameters. It sets the minimal " // & 'number every channel must be called. If the number of calls ' // & 'from the iterations is too small, \whizard\ will automatically ' // & 'increase the number of calls. (cf. \ttt{iterations}, \ttt{min\_calls\_per\_bin}, ' // & '\ttt{min\_bins}, \ttt{max\_bins})')) call var_list%append_int (var_str ("min_calls_per_bin"), 10, & intrinsic=.true., & description=var_str ('Integer parameter that modifies the settings ' // & "of the \vamp\ integrator's grid parameters. It sets the minimal " // & 'number every bin in an integration dimension must be called. ' // & 'If the number of calls from the iterations is too small, \whizard\ ' // & 'will automatically increase the number of calls. (cf. \ttt{iterations}, ' // & '\ttt{min\_calls\_per\_channel}, \ttt{min\_bins}, \ttt{max\_bins})')) call var_list%append_int (var_str ("min_bins"), 3, & intrinsic=.true., & description=var_str ('Integer parameter that modifies the settings ' // & "of the \vamp\ integrator's grid parameters. It sets the minimal " // & 'number of bins per integration dimension. (cf. \ttt{iterations}, ' // & '\ttt{max\_bins}, \ttt{min\_calls\_per\_channel}, \ttt{min\_calls\_per\_bin})')) call var_list%append_int (var_str ("max_bins"), 20, & intrinsic=.true., & description=var_str ('Integer parameter that modifies the settings ' // & "of the \vamp\ integrator's grid parameters. It sets the maximal " // & 'number of bins per integration dimension. (cf. \ttt{iterations}, ' // & '\ttt{min\_bins}, \ttt{min\_calls\_per\_channel}, \ttt{min\_calls\_per\_bin})')) call var_list%append_log (var_str ("?stratified"), .true., & intrinsic=.true., & description=var_str ('Flag that switches between stratified ' // & 'and importance sampling for the \vamp\ integration method.')) call var_list%append_log (var_str ("?use_vamp_equivalences"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether equivalence ' // & 'relations (symmetries) between different integration channels ' // & 'are used by the \vamp\ integrator.')) call var_list%append_log (var_str ("?vamp_verbose"), .false., & intrinsic=.true., & description=var_str ('Flag that sets the chattiness of the \vamp\ ' // & 'integrator. If set, not only errors, but also all warnings and ' // & 'messages will be written out (not the default). (cf. also \newline ' // & '\ttt{?vamp\_history\_global}, \ttt{?vamp\_history\_global\_verbose}, ' // & '\ttt{?vamp\_history\_channels}, \newline \ttt{?vamp\_history\_channels\_verbose})')) call var_list%append_log (var_str ("?vamp_history_global"), & .true., intrinsic=.true., & description=var_str ('Flag that decides whether the global history ' // & 'of the grid adaptation of the \vamp\ integrator are written ' // & 'into the process logfiles. (cf. also \ttt{?vamp\_history\_global\_verbose}, ' // & '\ttt{?vamp\_history\_channels}, \ttt{?vamp\_history\_channels\_verbose}, ' // & '\ttt{?vamp\_verbose})')) call var_list%append_log (var_str ("?vamp_history_global_verbose"), & .false., intrinsic=.true., & description=var_str ('Flag that decides whether the global history ' // & 'of the grid adaptation of the \vamp\ integrator are written ' // & 'into the process logfiles in an extended version. Only for debugging ' // & 'purposes. (cf. also \ttt{?vamp\_history\_global}, \ttt{?vamp\_history\_channels}, ' // & '\ttt{?vamp\_verbose}, \ttt{?vamp\_history\_channels\_verbose})')) call var_list%append_log (var_str ("?vamp_history_channels"), & .false., intrinsic=.true., & description=var_str ('Flag that decides whether the history of ' // & 'the grid adaptation of the \vamp\ integrator for every single ' // & 'channel are written into the process logfiles. Only for debugging ' // & 'purposes. (cf. also \ttt{?vamp\_history\_global\_verbose}, ' // & '\ttt{?vamp\_history\_global}, \ttt{?vamp\_verbose}, \newline ' // & '\ttt{?vamp\_history\_channels\_verbose})')) call var_list%append_log (var_str ("?vamp_history_channels_verbose"), & .false., intrinsic=.true., & description=var_str ('Flag that decides whether the history of ' // & 'the grid adaptation of the \vamp\ integrator for every single ' // & 'channel are written into the process logfiles in an extended ' // & 'version. Only for debugging purposes. (cf. also \ttt{?vamp\_history\_global}, ' // & '\ttt{?vamp\_history\_channels}, \ttt{?vamp\_verbose}, \ttt{?vamp\_history\_global\_verbose})')) call var_list%append_string (var_str ("$run_id"), var_str (""), & intrinsic=.true., & description=var_str ('String variable \ttt{\$run\_id = "{\em ' // & '}"} that allows to set a special ID for a particular process ' // & 'run, e.g. in a scan. The run ID is then attached to the process ' // & 'log file: \newline \ttt{{\em }\_{\em }.{\em ' // & '}.log}, the \vamp\ grid file: \newline \ttt{{\em }\_{\em ' // & '}.{\em }.vg}, and the phase space file: \newline ' // & '\ttt{{\em }\_{\em }.{\em }.phs}. ' // & 'The run ID string distinguishes among several runs for the ' // & 'same process. It identifies process instances with respect ' // & 'to adapted integration grids and similar run-specific data. ' // & 'The run ID is kept when copying processes for creating instances, ' // & 'however, so it does not distinguish event samples. (cf.\ also ' // & '\ttt{\$job\_id}, \ttt{\$compile\_workspace}')) call var_list%append_int (var_str ("n_calls_test"), 0, & intrinsic=.true., & description=var_str ('Integer variable that allows to set a ' // & 'certain number of matrix element sampling test calls without ' // & 'actually integrating the process under consideration. (cf. ' // & '\ttt{integrate})')) call var_list%append_log (var_str ("?integration_timer"), .true., & intrinsic=.true., & description=var_str ('This flag switches the integration timer ' // & 'on and off, that gives the estimate for the duration of the ' // & 'generation of 10,000 unweighted events for each integrated ' // & 'process.')) call var_list%append_log (var_str ("?check_grid_file"), .true., & intrinsic=.true., & description=var_str ('Setting this to false turns off all sanity ' // & 'checks when reading a grid file with previous integration data. ' // & 'Use this at your own risk; the program may return wrong results ' // & 'or crash if data do not match. (cf. also \ttt{?check\_event\_file}, \ttt{?check\_phs\_file}) ')) call var_list%append_real (var_str ("accuracy_goal"), 0._default, & intrinsic=.true., & description=var_str ('Real parameter that allows the user to ' // & 'set a minimal accuracy that should be achieved in the Monte-Carlo ' // & 'integration of a certain process. If that goal is reached, ' // & 'grid and weight adapation stop, and this result is used for ' // & 'simulation. (cf. also \ttt{integrate}, \ttt{iterations}, ' // & '\ttt{error\_goal}, \ttt{relative\_error\_goal}, ' // & '\ttt{error\_threshold})')) call var_list%append_real (var_str ("error_goal"), 0._default, & intrinsic=.true., & description=var_str ('Real parameter that allows the user to ' // & 'set a minimal absolute error that should be achieved in the ' // & 'Monte-Carlo integration of a certain process. If that goal ' // & 'is reached, grid and weight adapation stop, and this result ' // & 'is used for simulation. (cf. also \ttt{integrate}, \ttt{iterations}, ' // & '\ttt{accuracy\_goal}, \ttt{relative\_error\_goal}, \ttt{error\_threshold})')) call var_list%append_real (var_str ("relative_error_goal"), 0._default, & intrinsic=.true., & description=var_str ('Real parameter that allows the user to ' // & 'set a minimal relative error that should be achieved in the ' // & 'Monte-Carlo integration of a certain process. If that goal ' // & 'is reached, grid and weight adaptation stop, and this result ' // & 'is used for simulation. (cf. also \ttt{integrate}, \ttt{iterations}, ' // & '\ttt{accuracy\_goal}, \ttt{error\_goal}, \ttt{error\_threshold})')) call var_list%append_int (var_str ("integration_results_verbosity"), 1, & intrinsic=.true., & description=var_str ('Integer parameter for the verbosity of ' // & 'the integration results in the process-specific logfile.')) call var_list%append_real (var_str ("error_threshold"), & 0._default, intrinsic=.true., & description=var_str ('The real parameter \ttt{error\_threshold ' // & '= {\em }} declares that any error value (in absolute numbers) ' // & 'smaller than \ttt{{\em }} is to be considered zero. The ' // & 'units are \ttt{fb} for scatterings and \ttt{GeV} for decays. ' // & '(cf. also \ttt{integrate}, \ttt{iterations}, \ttt{accuracy\_goal}, ' // & '\ttt{error\_goal}, \ttt{relative\_error\_goal})')) call var_list%append_real (var_str ("channel_weights_power"), 0.25_default, & intrinsic=.true., & description=var_str ('Real parameter that allows to vary the ' // & 'exponent of the channel weights for the \vamp\ integrator.')) call var_list%append_string (var_str ("$integrate_workspace"), & intrinsic=.true., & description=var_str ('Character string that tells \whizard\ ' // & 'the subdirectory where to find the run-specific phase-space ' // & 'configuration and the \vamp\ and \vamptwo\ grid files. ' // & 'If undefined (as per default), \whizard\ creates them and ' // & 'searches for them in the ' // & 'current directory. (cf. also \ttt{\$job\_id}, ' // & '\ttt{\$run\_id}, \ttt{\$compile\_workspace})')) call var_list%append_int (var_str ("vamp_grid_checkpoint"), 1, & intrinsic=.true., & description=var_str ('Integer parameter for setting checkpoints to save ' // & 'the current state of the grids and the results so far of the integration. ' // & 'Allowed are all positive integer. Zero values corresponds to a checkpoint ' // & 'after each integration pass, a one value to a checkpoint after each iteration ' // & '(default) and an \(N\) value correspond to a checkpoint after \(N\) iterations ' // & ' or after each pass, respectively.')) call var_list%append_string (var_str ("$vamp_grid_format"), var_str ("ascii"), & intrinsic=.true., & description=var_str ('Character string that tells \whizard\ ' // & 'the file format for \ttt{vamp2} to use for writing and reading ' // & 'the configuration for the multi-channel integration setup and the ' // & '\vamptwo\ (only) grid data. The values can be \ttt{ascii} for a single ' // & 'human-readable grid file with ending \ttt{.vg2} or \ttt{binary} for two files, ' // & 'a human-readable header file with ending \ttt{.vg2} and binary file with ending ' // & '\ttt{.vgx2} storing the grid data.' // & 'The main purpose of the binary format is to perform faster I/O, e.g. for HPC runs.' // & '\whizard\ can convert between the different file formats automatically.')) call var_list%append_string (var_str ("$vamp_parallel_method"), var_str ("simple"), & intrinsic=.true., & description=var_str ('Character string that tells \whizard\ ' // & 'the parallel method to use for parallel integration within \ttt{vamp2}.' // & ' (i) \ttt{simple} (default) is a local work sharing approach without the need of communication ' // & 'between all workers except for the communication during result collection.' // & ' (ii) \ttt{load} is a global queue approach where the master worker acts as a' // & 'governor listening and providing work for each worker. The queue is filled and assigned with workers ' // & 'a-priori with respect to the assumed computational impact of each channel.' // & 'Both approaches use the same mechanism for result collection using non-blocking ' // & 'communication allowing for a efficient usage of the computing resources.')) end subroutine var_list_set_integration_defaults @ %def var_list_set_integration_defaults @ <>= procedure :: set_phase_space_defaults => var_list_set_phase_space_defaults <>= module subroutine var_list_set_phase_space_defaults (var_list) class(var_list_t), intent(inout) :: var_list end subroutine var_list_set_phase_space_defaults <>= module subroutine var_list_set_phase_space_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_string (var_str ("$phs_method"), var_str ("default"), & intrinsic=.true., & description=var_str ('String variable that allows to choose ' // & 'the phase-space parameterization method. The default is the ' // & '\ttt{"wood"} method that takes into account electroweak/BSM ' // & 'resonances. Note that this might not be the best choice for ' // & '(pure) QCD amplitudes. (cf. also \ttt{\$phs\_file})')) call var_list%append_log (var_str ("?vis_channels"), .false., & intrinsic=.true., & description=var_str ('Optional logical argument for the \ttt{integrate} ' // & 'command that demands \whizard\ to generate a PDF or postscript ' // & 'output showing the classification of the found phase space ' // & 'channels (if the phase space method \ttt{wood} has been used) ' // & 'according to their properties: \ttt{integrate (foo) \{ iterations=3:10000 ' // & '?vis\_channels = true \}}. The default is \ttt{false}. (cf. ' // & 'also \ttt{integrate}, \ttt{?vis\_history})')) call var_list%append_log (var_str ("?check_phs_file"), .true., & intrinsic=.true., & description=var_str ('Setting this to false turns off all sanity ' // & 'checks when reading a previously generated phase-space configuration ' // & 'file. Use this at your own risk; the program may return wrong ' // & 'results or crash if data do not match. (cf. also \ttt{?check\_event\_file}, ' // & '\ttt{?check\_grid\_file})')) call var_list%append_string (var_str ("$phs_file"), var_str (""), & intrinsic=.true., & description=var_str ('This string variable allows the user to ' // & 'set an individual file name for the phase space parameterization ' // & 'for a particular process: \ttt{\$phs\_file = "{\em }"}. ' // & 'If not set, the default is \ttt{{\em }\_{\em }.{\em ' // & '}.phs}. (cf. also \ttt{\$phs\_method})')) call var_list%append_log (var_str ("?phs_only"), .false., & intrinsic=.true., & description=var_str ('Flag (particularly as optional argument ' // & 'of the $\to$ \ttt{integrate} command) that allows to only generate ' // & 'the phase space file, but not perform the integration. (cf. ' // & 'also \ttt{\$phs\_method}, \ttt{\$phs\_file})')) call var_list%append_real (var_str ("phs_threshold_s"), 50._default, & intrinsic=.true., & description=var_str ('For the phase space method \ttt{wood}, ' // & 'this real parameter sets the threshold below which particles ' // & 'are assumed to be massless in the $s$-channel like kinematic ' // & 'regions. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_off\_shell}, ' // & '\ttt{phs\_t\_channel}, \ttt{phs\_e\_scale}, \ttt{phs\_m\_scale}, ' // & '\newline \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // & '\ttt{?phs\_step\_mapping\_exp}, \newline \ttt{?phs\_s\_mapping})')) call var_list%append_real (var_str ("phs_threshold_t"), 100._default, & intrinsic=.true., & description=var_str ('For the phase space method \ttt{wood}, ' // & 'this real parameter sets the threshold below which particles ' // & 'are assumed to be massless in the $t$-channel like kinematic ' // & 'regions. (cf. also \ttt{phs\_threshold\_s}, \ttt{phs\_off\_shell}, ' // & '\ttt{phs\_t\_channel}, \ttt{phs\_e\_scale}, \ttt{phs\_m\_scale}, ' // & '\newline \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // & '\ttt{?phs\_step\_mapping\_exp}, \newline \ttt{?phs\_s\_mapping})')) call var_list%append_int (var_str ("phs_off_shell"), 2, & intrinsic=.true., & description=var_str ('Integer parameter that sets the number ' // & 'of off-shell (not $t$-channel-like, non-resonant) lines that ' // & 'are taken into account to find a valid phase-space setup in ' // & 'the \ttt{wood} phase-space method. (cf. also \ttt{phs\_threshold\_t}, ' // & '\ttt{phs\_threshold\_s}, \ttt{phs\_t\_channel}, \ttt{phs\_e\_scale}, ' // & '\ttt{phs\_m\_scale}, \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, ' // & '\ttt{?phs\_step\_mapping}, \newline \ttt{?phs\_step\_mapping\_exp}, ' // & '\ttt{?phs\_s\_mapping})')) call var_list%append_int (var_str ("phs_t_channel"), 6, & intrinsic=.true., & description=var_str ('Integer parameter that sets the number ' // & 'of $t$-channel propagators in multi-peripheral diagrams that ' // & 'are taken into account to find a valid phase-space setup in ' // & 'the \ttt{wood} phase-space method. (cf. also \ttt{phs\_threshold\_t}, ' // & '\ttt{phs\_threshold\_s}, \ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, ' // & '\ttt{phs\_m\_scale}, \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, ' // & '\ttt{?phs\_step\_mapping}, \newline \ttt{?phs\_step\_mapping\_exp}, ' // & '\ttt{?phs\_s\_mapping})')) call var_list%append_real (var_str ("phs_e_scale"), 10._default, & intrinsic=.true., & description=var_str ('Real parameter that sets the energy scale ' // & 'that acts as a cutoff for parameterizing radiation-like kinematics ' // & 'in the \ttt{wood} phase space method. \whizard\ takes the maximum ' // & 'of this value and the width of the propagating particle as ' // & 'a cutoff. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // & '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_m\_scale}, ' // & '\ttt{phs\_q\_scale}, \newline \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // & '\ttt{?phs\_step\_mapping\_exp}, \ttt{?phs\_s\_mapping})')) call var_list%append_real (var_str ("phs_m_scale"), 10._default, & intrinsic=.true., & description=var_str ('Real parameter that sets the mass scale ' // & 'that acts as a cutoff for parameterizing collinear and infrared ' // & 'kinematics in the \ttt{wood} phase space method. \whizard\ ' // & 'takes the maximum of this value and the mass of the propagating ' // & 'particle as a cutoff. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // & '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, ' // & '\ttt{phs\_q\_scale}, \newline \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // & '\ttt{?phs\_step\_mapping\_exp}, \ttt{?phs\_s\_mapping})')) call var_list%append_real (var_str ("phs_q_scale"), 10._default, & intrinsic=.true., & description=var_str ('Real parameter that sets the momentum ' // & 'transfer scale that acts as a cutoff for parameterizing $t$- ' // & 'and $u$-channel like kinematics in the \ttt{wood} phase space ' // & 'method. \whizard\ takes the maximum of this value and the mass ' // & 'of the propagating particle as a cutoff. (cf. also \ttt{phs\_threshold\_t}, ' // & '\ttt{phs\_threshold\_s}, \ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, ' // & '\ttt{phs\_e\_scale}, \ttt{phs\_m\_scale}, \ttt{?phs\_keep\_resonant}, ' // & '\ttt{?phs\_step\_mapping}, \ttt{?phs\_step\_mapping\_exp}, ' // & '\newline \ttt{?phs\_s\_mapping})')) call var_list%append_log (var_str ("?phs_keep_nonresonant"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether the \ttt{wood} ' // & 'phase space method takes into account also non-resonant contributions. ' // & '(cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // & '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_m\_scale}, ' // & '\ttt{phs\_q\_scale}, \ttt{phs\_e\_scale}, \ttt{?phs\_step\_mapping}, ' // & '\newline \ttt{?phs\_step\_mapping\_exp}, \ttt{?phs\_s\_mapping})')) call var_list%append_log (var_str ("?phs_step_mapping"), .true., & intrinsic=.true., & description=var_str ('Flag that switches on (or off) a particular ' // & 'phase space mapping for resonances, where the mass and width ' // & 'of the resonance are explicitly set as channel cutoffs. (cf. ' // & 'also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, \ttt{phs\_t\_channel}, ' // & '\ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, \newline \ttt{phs\_m\_scale}, ' // & '\ttt{?phs\_keep\_resonant}, \ttt{?phs\_q\_scale}, \ttt{?phs\_step\_mapping\_exp}, ' // & '\newline \ttt{?phs\_s\_mapping})')) call var_list%append_log (var_str ("?phs_step_mapping_exp"), .true., & intrinsic=.true., & description=var_str ('Flag that switches on (or off) a particular ' // & 'phase space mapping for resonances, where the mass and width ' // & 'of the resonance are explicitly set as channel cutoffs. This ' // & 'is an exponential mapping in contrast to ($\to$) \ttt{?phs\_step\_mapping}. ' // & '(cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // & '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, ' // & '\ttt{phs\_m\_scale}, \newline \ttt{?phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, ' // & '\ttt{?phs\_step\_mapping}, \ttt{?phs\_s\_mapping})')) call var_list%append_log (var_str ("?phs_s_mapping"), .true., & intrinsic=.true., & description=var_str ('Flag that allows special mapping for $s$-channel ' // & 'resonances. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // & '\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, ' // & '\ttt{phs\_m\_scale}, \newline \ttt{?phs\_keep\_resonant}, \ttt{?phs\_q\_scale}, ' // & '\ttt{?phs\_step\_mapping}, \ttt{?phs\_step\_mapping\_exp})')) call var_list%append_log (var_str ("?vis_history"), .false., & intrinsic=.true., & description=var_str ('Optional logical argument for the \ttt{integrate} ' // & 'command that demands \whizard\ to generate a PDF or postscript ' // & 'output showing the adaptation history of the Monte-Carlo integration ' // & 'of the process under consideration. (cf. also \ttt{integrate}, ' // & '\ttt{?vis\_channels})')) end subroutine var_list_set_phase_space_defaults @ %def var_list_set_phase_space_defaults @ <>= procedure :: set_gamelan_defaults => var_list_set_gamelan_defaults <>= module subroutine var_list_set_gamelan_defaults (var_list) class(var_list_t), intent(inout) :: var_list end subroutine var_list_set_gamelan_defaults <>= module subroutine var_list_set_gamelan_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_int (& var_str ("n_bins"), 20, & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: integer value that sets the number of bins in histograms. ' // & '(cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, \ttt{\$obs\_unit}, ' // & '\ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, \ttt{\$y\_label}, ' // & '\ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, \ttt{?y\_log}, ' // & '\ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, ' // & '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // & '\newline \ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // & '\ttt{\$symbol})')) call var_list%append_log (& var_str ("?normalize_bins"), .false., & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that determines whether the weights shall be normalized ' // & 'to the bin width or not. (cf. also \ttt{n\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // & '\newline \ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \newline ' // & '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // & '\ttt{\$err\_options})')) call var_list%append_string (var_str ("$obs_label"), var_str (""), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: this is a string variable \ttt{\$obs\_label = "{\em ' // & '}"} that allows to attach a label to a plotted ' // & 'or histogrammed observable. (cf. also \ttt{n\_bins}, \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // & '\ttt{graph\_height\_mm}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, ' // & '\ttt{?draw\_histogram}, \ttt{?draw\_piecewise}, \newline \ttt{?fill\_curve}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})')) call var_list%append_string (var_str ("$obs_unit"), var_str (""), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: this is a string variable \ttt{\$obs\_unit = "{\em ' // & '}"} that allows to attach a \LaTeX\ physical unit ' // & 'to a plotted or histogrammed observable. (cf. also \ttt{n\_bins}, ' // & '\ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{?y\_log}, \ttt{?x\_log}, ' // & '\ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, \ttt{x\_min}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \ttt{?draw\_histogram}, ' // & '\ttt{?fill\_curve}, \ttt{?draw\_piecewise}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})')) call var_list%append_string (var_str ("$title"), var_str (""), & intrinsic=.true., & description=var_str ('This string variable sets the title of ' // & 'a plot in a \whizard\ analysis setup, e.g. a histogram or an ' // & 'observable. The syntax is \ttt{\$title = "{\em }"}. ' // & 'This title appears as a section header in the analysis file, ' // & 'but not in the screen output of the analysis. (cf. also \ttt{n\_bins}, ' // & '\ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{?y\_log}, \ttt{?x\_log}, ' // & '\ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, \ttt{x\_min}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \ttt{?draw\_histogram}, ' // & '\ttt{?fill\_curve}, \ttt{?draw\_piecewise}, \newline \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})')) call var_list%append_string (var_str ("$description"), var_str (""), & intrinsic=.true., & description=var_str ('String variable that allows to specify ' // & 'a description text for the analysis, \ttt{\$description = "{\em ' // & '}"}. This line appears below the title ' // & 'of a corresponding analysis, on top of the respective plot. ' // & '(cf. also \ttt{analysis}, \ttt{n\_bins}, \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_unit}, \ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{?y\_log}, ' // & '\ttt{?x\_log}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \ttt{?draw\_histogram}, ' // & '\ttt{?fill\_curve}, \ttt{?draw\_piecewise}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})')) call var_list%append_string (var_str ("$x_label"), var_str (""), & intrinsic=.true., & description=var_str ('String variable, \ttt{\$x\_label = "{\em ' // & '}"}, that sets the $x$ axis label in a plot or ' // & 'histogram in a \whizard\ analysis. (cf. also \ttt{analysis}, ' // & '\ttt{n\_bins}, \ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{\$y\_label}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // & '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, ' // & '\ttt{?draw\_histogram}, \ttt{?fill\_curve}, \newline \ttt{?draw\_piecewise}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})')) call var_list%append_string (var_str ("$y_label"), var_str (""), & intrinsic=.true., & description=var_str ('String variable, \ttt{\$y\_label = "{\em ' // & '}"}, that sets the $y$ axis label in a plot or ' // & 'histogram in a \whizard\ analysis. (cf. also \ttt{analysis}, ' // & '\ttt{n\_bins}, \ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{?y\_log}, ' // & '\ttt{?x\_log}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // & '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, ' // & '\ttt{?draw\_histogram}, \ttt{?fill\_curve}, \newline \ttt{?draw\_piecewise}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // & '\newline \ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})')) call var_list%append_int (var_str ("graph_width_mm"), 130, & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: integer value that sets the width of a graph or histogram ' // & 'in millimeters. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, ' // & '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, \ttt{?draw\_base}, ' // & '\newline \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \ttt{?draw\_symbols}, \newline \ttt{\$fill\_options}, ' // & '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_int (var_str ("graph_height_mm"), 90, & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: integer value that sets the height of a graph or histogram ' // & 'in millimeters. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, ' // & '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, \ttt{?draw\_base}, ' // & '\newline \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \ttt{?draw\_symbols}, \newline \ttt{\$fill\_options}, ' // & '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_log (var_str ("?y_log"), .false., & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that makes the $y$ axis logarithmic. (cf. also ' // & '\ttt{?normalize\_bins}, \ttt{\$obs\_label}, \ttt{\$obs\_unit}, ' // & '\ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, \ttt{\$y\_label}, ' // & '\ttt{graph\_height\_mm}, \ttt{graph\_width\_mm}, \ttt{?y\_log}, ' // & '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // & '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \newline \ttt{?fill\_curve}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // & '\ttt{\$symbol})')) call var_list%append_log (var_str ("?x_log"), .false., & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that makes the $x$ axis logarithmic. (cf. also ' // & '\ttt{?normalize\_bins}, \ttt{\$obs\_label}, \ttt{\$obs\_unit}, ' // & '\ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, \ttt{\$y\_label}, ' // & '\ttt{graph\_height\_mm}, \ttt{graph\_width\_mm}, \ttt{?y\_log}, ' // & '\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // & '\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \newline \ttt{?fill\_curve}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // & '\ttt{\$symbol})')) call var_list%append_real (var_str ("x_min"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: real parameter that sets the lower limit of the $x$ ' // & 'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // & '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_real (var_str ("x_max"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: real parameter that sets the upper limit of the $x$ ' // & 'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // & '\ttt{x\_min}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // & '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_real (var_str ("y_min"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: real parameter that sets the lower limit of the $y$ ' // & 'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // & '\ttt{x\_max}, \ttt{y\_max}, \ttt{x\_min}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // & '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_real (var_str ("y_max"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: real parameter that sets the upper limit of the $y$ ' // & 'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // & '\ttt{x\_max}, \ttt{x\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // & '\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_string (var_str ("$gmlcode_bg"), var_str (""), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: string variable that allows to define a background ' // & 'for plots and histograms (i.e. it is overwritten by the plot/histogram), ' // & 'e.g. a grid: \ttt{\$gmlcode\_bg = "standardgrid.lr(5);"}. For ' // & 'more details, see the \gamelan\ manual. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // & '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, ' // & '\ttt{?draw\_histogram}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // & '\newline \ttt{?fill\_curve}, \ttt{?draw\_curve}, \ttt{?draw\_errors}, ' // & '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, ' // & '\ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_string (var_str ("$gmlcode_fg"), var_str (""), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: string variable that allows to define a foreground ' // & 'for plots and histograms (i.e. it overwrites the plot/histogram), ' // & 'e.g. a grid: \ttt{\$gmlcode\_bg = "standardgrid.lr(5);"}. For ' // & 'more details, see the \gamelan\ manual. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // & '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{?draw\_histogram}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // & '\newline \ttt{?fill\_curve}, \ttt{?draw\_curve}, \ttt{?draw\_errors}, ' // & '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, ' // & '\ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_log (var_str ("?draw_histogram"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that tells \whizard\ to either plot data as a ' // & 'histogram or as a continuous line (if $\to$ \ttt{?draw\_curve} ' // & 'is set \ttt{true}). (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // & '\ttt{\$symbol})')) call var_list%append_log (var_str ("?draw_base"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that tells \whizard\ to insert a \ttt{base} statement ' // & 'in the analysis code to calculate the plot data from a data ' // & 'set. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // & '\ttt{\$symbol}, \newline \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // & '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // & '\newline \ttt{\$err\_options})')) call var_list%append_log (var_str ("?draw_piecewise"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that tells \whizard\ to data from a data set piecewise, ' // & 'i.e. histogram style. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, ' // & '\ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_base}, \ttt{?fill\_curve}, ' // & '\ttt{\$symbol}, \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // & '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // & '\ttt{\$err\_options})')) call var_list%append_log (var_str ("?fill_curve"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that tells \whizard\ to fill data curves (e.g. ' // & 'as a histogram). The style can be set with $\to$ \ttt{\$fill\_options ' // & '= "{\em }"}. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // & '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, ' // & '\ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // & '\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // & '\ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_log (var_str ("?draw_curve"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that tells \whizard\ to either plot data as a ' // & 'continuous line or as a histogram (if $\to$ \ttt{?draw\_histogram} ' // & 'is set \ttt{true}). (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // & '\ttt{?draw\_histogram}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // & '\ttt{\$symbol})')) call var_list%append_log (var_str ("?draw_errors"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that determines whether error bars should be drawn ' // & 'or not. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, ' // & '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // & '\newline \ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_log (var_str ("?draw_symbols"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: flag that determines whether particular symbols (specified ' // & 'by $\to$ \ttt{\$symbol = "{\em }"}) should be ' // & 'used for plotting data points (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // & '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, ' // & '\ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // & '\ttt{?fill\_curve}, \ttt{?draw\_histogram}, \ttt{?draw\_curve}, ' // & '\ttt{?draw\_errors}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // & '\newline \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_string (var_str ("$fill_options"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: \ttt{\$fill\_options = "{\em }"} is a ' // & 'string variable that allows to set fill options when plotting ' // & 'data as filled curves with the $\to$ \ttt{?fill\_curve} flag. ' // & 'For more details see the \gamelan\ manual. (cf. also \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // & '\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // & '\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // & '\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, ' // & '\ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // & '\ttt{?draw\_curve}, \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // & '\newline \ttt{?draw\_symbols}, \ttt{?fill\_curve}, \ttt{\$draw\_options}, ' // & '\ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_string (var_str ("$draw_options"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: \ttt{\$draw\_options = "{\em }"} is a ' // & 'string variable that allows to set specific drawing options ' // & 'for plots and histograms. For more details see the \gamelan\ ' // & 'manual. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, ' // & '\newline \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_errors}, \ttt{?draw\_symbols}, \newline \ttt{\$fill\_options}, ' // & '\ttt{?draw\_histogram}, \ttt{\$err\_options}, \ttt{\$symbol})')) call var_list%append_string (var_str ("$err_options"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: \ttt{\$err\_options = "{\em }"} is a string ' // & 'variable that allows to set specific drawing options for errors ' // & 'in plots and histograms. For more details see the \gamelan\ ' // & 'manual. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, ' // & '\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_histogram}, ' // & '\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // & '\ttt{?draw\_histogram}, \ttt{\$draw\_options}, \ttt{\$symbol})')) call var_list%append_string (var_str ("$symbol"), & intrinsic=.true., & description=var_str ("Settings for \whizard's internal graphics " // & 'output: \ttt{\$symbol = "{\em }"} is a string ' // & 'variable for the symbols that should be used for plotting data ' // & 'points. (cf. also \ttt{\$obs\_label}, \ttt{?normalize\_bins}, ' // & '\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // & '\ttt{\$y\_label}, \newline \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // & '\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // & '\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // & '\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // & '\newline \ttt{?draw\_histogram}, \ttt{?draw\_curve}, \ttt{?draw\_errors}, ' // & '\ttt{\$fill\_options}, \ttt{\$draw\_options}, \newline \ttt{\$err\_options}, ' // & '\ttt{?draw\_symbols})')) call var_list%append_log (& var_str ("?analysis_file_only"), .false., & intrinsic=.true., & description=var_str ('Allows to specify that only \LaTeX\ files ' // & "for \whizard's graphical analysis are written out, but not processed. " // & '(cf. \ttt{compile\_analysis}, \ttt{write\_analysis})')) end subroutine var_list_set_gamelan_defaults @ %def var_list_set_gamelan_defaults @ FastJet parameters and friends <>= procedure :: set_clustering_defaults => var_list_set_clustering_defaults <>= module subroutine var_list_set_clustering_defaults (var_list) class(var_list_t), intent(inout) :: var_list end subroutine var_list_set_clustering_defaults <>= module subroutine var_list_set_clustering_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_int (& var_str ("kt_algorithm"), & kt_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the ' // & 'interfaced external \fastjet\ package. (cf. also ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, ' // & '\ttt{plugin\_algorithm}, ' // & '\newline\ttt{genkt\_[for\_passive\_]algorithm}, ' // & '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_r})')) call var_list%append_int (& var_str ("cambridge_algorithm"), & cambridge_algorithm, intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_for\_passive\_algorithm}, \ttt{plugin\_algorithm}, ' // & '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // & '\ttt{jet\_r})')) call var_list%append_int (& var_str ("antikt_algorithm"), & antikt_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{plugin\_algorithm}, ' // & '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // & '\ttt{jet\_r})')) call var_list%append_int (& var_str ("genkt_algorithm"), & genkt_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_for\_passive\_algorithm}, \ttt{plugin\_algorithm}, ' // & '\ttt{genkt\_for\_passive\_algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // & '\ttt{jet\_r}), \ttt{jet\_p}')) call var_list%append_int (& var_str ("cambridge_for_passive_algorithm"), & cambridge_for_passive_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_algorithm}, \ttt{plugin\_algorithm}, \newline ' // & '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // & '\ttt{jet\_r})')) call var_list%append_int (& var_str ("genkt_for_passive_algorithm"), & genkt_for_passive_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_for\_passive\_algorithm}, \ttt{plugin\_algorithm}, ' // & '\ttt{genkt\_algorithm}, \ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_r})')) call var_list%append_int (& var_str ("ee_kt_algorithm"), & ee_kt_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{plugin\_algorithm}, ' // & '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_genkt\_algorithm}, ' // & '\ttt{jet\_r})')) call var_list%append_int (& var_str ("ee_genkt_algorithm"), & ee_genkt_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{plugin\_algorithm}, ' // & '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_kt\_algorithm}, ' // & '\ttt{jet\_r}), \ttt{jet\_p})')) call var_list%append_int (& var_str ("plugin_algorithm"), & plugin_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('Specifies a jet algorithm for the ($\to$) ' // & '\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // & 'subevent function. At the moment only available for the interfaced ' // & 'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_for\_passive\_algorithm}, \newline ' // & '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // & '\ttt{jet\_r})')) call var_list%append_int (& var_str ("undefined_jet_algorithm"), & undefined_jet_algorithm, & intrinsic = .true., locked = .true., & description=var_str ('This is just a place holder for any kind of jet ' // & 'jet algorithm that is not further specified. (cf. also \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_for\_passive\_algorithm}, \newline ' // & '\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // & '\ttt{jet\_r}, \ttt{plugin\_algorithm})')) call var_list%append_int (& var_str ("jet_algorithm"), undefined_jet_algorithm, & intrinsic = .true., & description=var_str ('Variable that allows to set the type of ' // & 'jet algorithm when using the external \fastjet\ library. It ' // & 'accepts one of the following algorithms: ($\to$) \ttt{kt\_algorithm}, ' // & '\newline ($\to$) \ttt{cambridge\_[for\_passive\_]algorithm}, ' // & '($\to$) \ttt{antikt\_algorithm}, ($\to$) \ttt{plugin\_algorithm}, ' // & '($\to$) \ttt{genkt\_[for\_passive\_]algorithm}, ($\to$) ' // & '\ttt{ee\_[gen]kt\_algorithm}). (cf. also \ttt{cluster}, ' // & '\ttt{jet\_p}, \ttt{jet\_r}, \ttt{jet\_ycut})')) call var_list%append_real (& var_str ("jet_r"), 0._default, & intrinsic = .true., & description=var_str ('Value for the distance measure $R$ used in ' // & 'some algorithms that are available via the interface ' // & 'to the \fastjet\ package. (cf. also \ttt{cluster}, \ttt{combine}, ' // & '\ttt{jet\_algorithm}, \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // & '\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // & '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_p}, \newline\ttt{jet\_ycut})')) call var_list%append_real (& var_str ("jet_p"), 0._default, & intrinsic = .true., & description=var_str ('Value for the exponent of the distance measure $R$ in ' // & 'the generalized $k_T$ algorithms that are available via the interface ' // & 'to the \fastjet\ package. (cf. also \ttt{cluster}, \ttt{combine}, ' // & '\ttt{jet\_algorithm}, \ttt{kt\_algorithm}, ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // & '\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // & '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_r}, \newline\ttt{jet\_ycut})')) call var_list%append_real (& var_str ("jet_ycut"), 0._default, & intrinsic = .true., & description=var_str ('Value for the $y$ separation measure used in ' // & 'the Cambridge-Aachen algorithms that are available via the interface ' // & 'to the \fastjet\ package. (cf. also \ttt{cluster}, \ttt{combine}, ' // & '\ttt{kt\_algorithm}, \ttt{jet\_algorithm}, ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // & '\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // & '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_p}, \newline\ttt{jet\_r})')) call var_list%append_real (& var_str ("jet_dcut"), 0._default, & intrinsic = .true., & description=var_str ('Value for the $d_{ij}$ separation measure used in ' // & 'the $e^+e^- k_T$ algorithms that are available via the interface ' // & 'to the \fastjet\ package. (cf. also \ttt{cluster}, \ttt{combine}, ' // & '\ttt{kt\_algorithm}, \ttt{jet\_algorithm}, ' // & '\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // & '\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // & '\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_p}, \newline\ttt{jet\_r})')) call var_list%append_log (& var_str ("?keep_flavors_when_clustering"), .false., & intrinsic = .true., & description=var_str ('The logical variable \ttt{?keep\_flavors\_when\_clustering ' // & '= true/false} specifies whether the flavor of a jet should be ' // & 'kept during \ttt{cluster} when a jet consists of one quark and ' // & 'zero or more gluons. Especially useful for cuts on b-tagged ' // & 'jets (cf. also \ttt{cluster}).')) end subroutine var_list_set_clustering_defaults @ %def var_list_set_clustering_defaults @ Frixione isolation and photon recombination parameters and all that: <>= procedure :: set_isolation_recomb_defaults => & var_list_set_isolation_recomb_defaults <>= module subroutine var_list_set_isolation_recomb_defaults (var_list) class(var_list_t), intent(inout) :: var_list end subroutine var_list_set_isolation_recomb_defaults <>= module subroutine var_list_set_isolation_recomb_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_real (var_str ("photon_iso_eps"), 1._default, & intrinsic=.true., & description=var_str ('Photon isolation parameter $\epsilon_\gamma$ ' // & '(energy fraction) from hep-ph/9801442 (cf. also ' // & '\ttt{photon\_iso\_n}, \ttt{photon\_iso\_r0})')) call var_list%append_real (var_str ("photon_iso_n"), 1._default, & intrinsic=.true., & description=var_str ('Photon isolation parameter $n$ ' // & '(cone function exponent) from hep-ph/9801442 (cf. also ' // & '\ttt{photon\_iso\_eps}, \ttt{photon\_iso\_r0})')) call var_list%append_real (var_str ("photon_iso_r0"), 0.4_default, & intrinsic=.true., & description=var_str ('Photon isolation parameter $R_0^\gamma$ ' // & '(isolation cone radius) from hep-ph/9801442 (cf. also ' // & '\ttt{photon\_iso\_eps}, \ttt{photon\_iso\_n})')) call var_list%append_real (var_str ("photon_rec_r0"), 0.1_default, & intrinsic=.true., & description=var_str ('Photon recombination parameter $R_0^\gamma$ ' // & 'for photon recombination in NLO EW calculations')) call var_list%append_log (& var_str ("?keep_flavors_when_recombining"), .true., & intrinsic = .true., & description=var_str ('The logical variable \ttt{?keep\_flavors\_when\_recombining ' // & '= true/false} specifies whether the flavor of a particle should be ' // & 'kept during \ttt{photon\_recombination} when a jet/lepton consists of one lepton/quark ' // & 'and zero or more photons (cf. also \ttt{photon\_recombination}).')) end subroutine var_list_set_isolation_recomb_defaults @ %def var_list_set_isolation_recomb_defaults <>= procedure :: set_eio_defaults => var_list_set_eio_defaults <>= module subroutine var_list_set_eio_defaults (var_list) class(var_list_t), intent(inout) :: var_list end subroutine var_list_set_eio_defaults <>= module subroutine var_list_set_eio_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_string (var_str ("$sample"), var_str (""), & intrinsic=.true., & description=var_str ('String variable to set the (base) name ' // & 'of the event output format, e.g. \ttt{\$sample = "foo"} will ' // & 'result in an intrinsic binary format event file \ttt{foo.evx}. ' // & '(cf. also \ttt{sample\_format}, \ttt{simulate}, \ttt{hepevt}, ' // & '\ttt{ascii}, \ttt{athena}, \ttt{debug}, \ttt{long}, \ttt{short}, ' // & '\ttt{hepmc}, \ttt{lhef}, \ttt{lha}, \ttt{stdhep}, \ttt{stdhep\_up}, ' // & '\ttt{\$sample\_normalization}, \ttt{?sample\_pacify}, \ttt{sample\_max\_tries})')) call var_list%append_string (var_str ("$sample_normalization"), var_str ("auto"),& intrinsic=.true., & description=var_str ('String variable that allows to set the ' // & 'normalization of generated events. There are four options: ' // & 'option \ttt{"1"} (events normalized to one), \ttt{"1/n"} (sum ' // & 'of all events in a sample normalized to one), \ttt{"sigma"} ' // & '(events normalized to the cross section of the process), and ' // & '\ttt{"sigma/n"} (sum of all events normalized to the cross ' // & 'section). The default is \ttt{"auto"} where unweighted events ' // & 'are normalized to one, and weighted ones to the cross section. ' // & '(cf. also \ttt{simulate}, \ttt{\$sample}, \ttt{sample\_format}, ' // & '\ttt{?sample\_pacify}, \ttt{sample\_max\_tries}, \ttt{sample\_split\_n\_evt}, ' // & '\ttt{sample\_split\_n\_kbytes})')) call var_list%append_log (var_str ("?sample_pacify"), .false., & intrinsic=.true., & description=var_str ('Flag, mainly for debugging purposes: suppresses ' // & 'numerical noise in the output of a simulation. (cf. also \ttt{simulate}, ' // & '\ttt{\$sample}, \ttt{sample\_format}, \ttt{\$sample\_normalization}, ' // & '\ttt{sample\_max\_tries}, \ttt{sample\_split\_n\_evt}, ' // & '\ttt{sample\_split\_n\_kbytes})')) call var_list%append_log (var_str ("?sample_select"), .true., & intrinsic=.true., & description=var_str ('Logical that determines whether a selection should ' // & 'be applied to the output event format or not. If set to \ttt{false} a ' // & 'selection is only considered for the evaluation of observables. (cf. ' // & '\ttt{select}, \ttt{selection}, \ttt{analysis})')) call var_list%append_int (var_str ("sample_max_tries"), 10000, & intrinsic = .true., & description=var_str ('Integer variable that sets the maximal ' // & 'number of tries for generating a single event. The event might ' // & 'be vetoed because of a very low unweighting efficiency, errors ' // & 'in the event transforms like decays, shower, matching, hadronization ' // & 'etc. (cf. also \ttt{simulate}, \ttt{\$sample}, \ttt{sample\_format}, ' // & '\ttt{?sample\_pacify}, \ttt{\$sample\_normalization}, ' // & '\ttt{sample\_split\_n\_evt}, \newline\ttt{sample\_split\_n\_kbytes})')) call var_list%append_int (var_str ("sample_split_n_evt"), 0, & intrinsic = .true., & description=var_str ('When generating events, this integer parameter ' // & '\ttt{sample\_split\_n\_evt = {\em }} gives the number \ttt{{\em ' // & '}} of breakpoints in the event files, i.e. it splits the ' // & 'event files into \ttt{{\em } + 1} parts. The parts are ' // & 'denoted by \ttt{{\em }.{\em }.{\em ' // & '}}. Here, \ttt{{\em }} is an integer ' // & 'running from \ttt{0} to \ttt{{\em }}. The start can be ' // & 'reset by ($\to$) \ttt{sample\_split\_index}. (cf. also \ttt{simulate}, ' // & '\ttt{\$sample}, \ttt{sample\_format}, \ttt{sample\_max\_tries}, ' // & '\ttt{\$sample\_normalization}, \ttt{?sample\_pacify}, ' // & '\ttt{sample\_split\_n\_kbytes})')) call var_list%append_int (var_str ("sample_split_n_kbytes"), 0, & intrinsic = .true., & description=var_str ('When generating events, this integer parameter ' // & '\ttt{sample\_split\_n\_kbytes = {\em }} limits the file ' // & 'size of event files. Whenever an event file has exceeded this ' // & 'size, counted in kilobytes, the following events will be written ' // & 'to a new file. The naming conventions are the same as for ' // & '\ttt{sample\_split\_n\_evt}. (cf. also \ttt{simulate}, \ttt{\$sample}, ' // & '\ttt{sample\_format}, \ttt{sample\_max\_tries}, \ttt{\$sample\_normalization}, ' // & '\ttt{?sample\_pacify})')) call var_list%append_int (var_str ("sample_split_index"), 0, & intrinsic = .true., & description=var_str ('Integer number that gives the starting ' // & 'index \ttt{sample\_split\_index = {\em }} for ' // & 'the numbering of event samples \ttt{{\em }.{\em ' // & '}.{\em }} split by the \ttt{sample\_split\_n\_evt ' // & '= {\em }}. The index runs from \ttt{{\em }} ' // & 'to \newline \ttt{{\em } + {\em }}. (cf. also \ttt{simulate}, ' // & '\ttt{\$sample}, \ttt{sample\_format}, \newline\ttt{\$sample\_normalization}, ' // & '\ttt{sample\_max\_tries}, \ttt{?sample\_pacify})')) call var_list%append_string (var_str ("$rescan_input_format"), var_str ("raw"), & intrinsic=.true., & description=var_str ('String variable that allows to set the ' // & 'event format of the event file that is to be rescanned by the ' // & '($\to$) \ttt{rescan} command.')) call var_list%append_log (var_str ("?read_raw"), .true., & intrinsic=.true., & description=var_str ('This flag demands \whizard\ to (try to) ' // & 'read events (from the internal binary format) first before ' // & 'generating new ones. (cf. \ttt{simulate}, \ttt{?write\_raw}, ' // & '\ttt{\$sample}, \ttt{sample\_format})')) call var_list%append_log (var_str ("?write_raw"), .true., & intrinsic=.true., & description=var_str ("Flag to write out events in \whizard's " // & 'internal binary format. (cf. \ttt{simulate}, \ttt{?read\_raw}, ' // & '\ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_raw"), var_str ("evx"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_raw ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & "to which events in \whizard's internal format are written. If " // & 'not set, the default file name and suffix is \ttt{{\em }.evx}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_default"), var_str ("evt"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_default ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in a the standard \whizard\ verbose ASCII format ' // & 'are written. If not set, the default file name and suffix is ' // & '\ttt{{\em }.evt}. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample})')) call var_list%append_string (var_str ("$debug_extension"), var_str ("debug"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$debug\_extension ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in a long verbose format with debugging information ' // & 'are written. If not set, the default file name and suffix is ' // & '\ttt{{\em }.debug}. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample}, \ttt{?debug\_process}, \ttt{?debug\_transforms}, ' // & '\ttt{?debug\_decay}, \ttt{?debug\_verbose})')) call var_list%append_log (var_str ("?debug_process"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether process information ' // & 'will be displayed in the ASCII debug event format ($\to$) \ttt{debug}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample}, \ttt{\$debug\_extension}, ' // & '\ttt{?debug\_decay}, \ttt{?debug\_transforms}, \ttt{?debug\_verbose})')) call var_list%append_log (var_str ("?debug_transforms"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether information ' // & 'about event transforms will be displayed in the ASCII debug ' // & 'event format ($\to$) \ttt{debug}. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample}, \ttt{?debug\_decay}, \ttt{\$debug\_extension}, ' // & '\ttt{?debug\_process}, \ttt{?debug\_verbose})')) call var_list%append_log (var_str ("?debug_decay"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether decay information ' // & 'will be displayed in the ASCII debug event format ($\to$) \ttt{debug}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample}, \ttt{\$debug\_extension}, ' // & '\ttt{?debug\_process}, \ttt{?debug\_transforms}, \ttt{?debug\_verbose})')) call var_list%append_log (var_str ("?debug_verbose"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether extensive verbose ' // & 'information will be included in the ASCII debug event format ' // & '($\to$) \ttt{debug}. (cf. also \ttt{sample\_format}, \ttt{\$sample}, ' // & '\ttt{\$debug\_extension}, \ttt{?debug\_decay}, \ttt{?debug\_transforms}, ' // & '\ttt{?debug\_process})')) call var_list%append_string (var_str ("$dump_extension"), var_str ("pset.dat"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$dump\_extension ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & "to which events in \whizard's internal particle set format " // & 'are written. If not set, the default file name and suffix is ' // & '\ttt{{\em }.pset.dat}. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // & '\ttt{?dump\_screen}, \ttt{?dump\_summary}, \ttt{?dump\_weights})')) call var_list%append_log (var_str ("?dump_compressed"), .false., & intrinsic=.true., & description=var_str ('Flag that, if set to \ttt{true}, issues ' // & 'a very compressed and clear version of the \ttt{dump} ($\to$) ' // & 'event format. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample}, \ttt{dump}, \ttt{\$dump\_extension}, ' // & '\ttt{?dump\_screen}, \ttt{?dump\_summary}, \ttt{?dump\_weights})')) call var_list%append_log (var_str ("?dump_weights"), .false., & intrinsic=.true., & description=var_str ('Flag that, if set to \ttt{true}, includes ' // & 'cross sections, weights and excess in the \ttt{dump} ($\to$) ' // & 'event format. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // & '\ttt{\$dump\_extension}, \ttt{?dump\_screen}, \ttt{?dump\_summary})')) call var_list%append_log (var_str ("?dump_summary"), .false., & intrinsic=.true., & description=var_str ('Flag that, if set to \ttt{true}, includes ' // & 'a summary with momentum sums for incoming and outgoing particles ' // & 'as well as for beam remnants in the \ttt{dump} ($\to$) ' // & 'event format. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // & '\ttt{\$dump\_extension}, \ttt{?dump\_screen}, \ttt{?dump\_weights})')) call var_list%append_log (var_str ("?dump_screen"), .false., & intrinsic=.true., & description=var_str ('Flag that, if set to \ttt{true}, outputs ' // & 'events for the \ttt{dump} ($\to$) event format on screen ' // & ' instead of to a file. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // & '\ttt{\$dump\_extension}, \ttt{?dump\_summary}, \ttt{?dump\_weights})')) call var_list%append_log (var_str ("?hepevt_ensure_order"), .false., & intrinsic=.true., & description=var_str ('Flag to ensure that the particle set confirms ' // & 'the HEPEVT standard. This involves some copying and reordering ' // & 'to guarantee that mothers and daughters are always next to ' // & 'each other. Usually this is not necessary.')) call var_list%append_string (var_str ("$extension_hepevt"), var_str ("hepevt"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_hepevt ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the \whizard\ version 1 style HEPEVT ASCII ' // & 'format are written. If not set, the default file name and suffix ' // & 'is \ttt{{\em }.hepevt}. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample})')) call var_list%append_string (var_str ("$extension_ascii_short"), & var_str ("short.evt"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_ascii\_short ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the so called short variant of the \whizard\ ' // & 'version 1 style HEPEVT ASCII format are written. If not set, ' // & 'the default file name and suffix is \ttt{{\em }.short.evt}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_ascii_long"), & var_str ("long.evt"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_ascii\_long ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the so called long variant of the \whizard\ ' // & 'version 1 style HEPEVT ASCII format are written. If not set, ' // & 'the default file name and suffix is \ttt{{\em }.long.evt}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_athena"), & var_str ("athena.evt"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_athena ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the ATHENA file format are written. If not ' // & 'set, the default file name and suffix is \ttt{{\em }.athena.evt}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_mokka"), & var_str ("mokka.evt"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_mokka ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the MOKKA format are written. If not set, ' // & 'the default file name and suffix is \ttt{{\em }.mokka.evt}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$lhef_version"), var_str ("2.0"), & intrinsic = .true., & description=var_str ('Specifier for the Les Houches Accord (LHEF) ' // & 'event format files with XML headers to discriminate among different ' // & 'versions of this format. (cf. also \ttt{\$sample}, \ttt{sample\_format}, ' // & '\ttt{lhef}, \ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, ' // & '\ttt{?lhef\_write\_sqme\_prc}, \ttt{?lhef\_write\_sqme\_ref}, ' // & '\ttt{?lhef\_write\_sqme\_alt})')) call var_list%append_string (var_str ("$lhef_extension"), var_str ("lhe"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$lhef\_extension ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the LHEF format are written. If not set, ' // & 'the default file name and suffix is \ttt{{\em }.lhe}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample}, \ttt{lhef}, ' // & '\ttt{\$lhef\_extension}, \ttt{\$lhef\_version}, \ttt{?lhef\_write\_sqme\_prc}, ' // & '\ttt{?lhef\_write\_sqme\_ref}, \ttt{?lhef\_write\_sqme\_alt})')) call var_list%append_log (var_str ("?lhef_write_sqme_prc"), .true., & intrinsic = .true., & description=var_str ('Flag that decides whether in the ($\to$) ' // & '\ttt{lhef} event format the weights of the squared matrix element ' // & 'of the corresponding process shall be written in the LHE file. ' // & '(cf. also \ttt{\$sample}, \ttt{sample\_format}, \ttt{lhef}, ' // & '\ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, \ttt{?lhef\_write\_sqme\_ref}, ' // & '\newline \ttt{?lhef\_write\_sqme\_alt})')) call var_list%append_log (var_str ("?lhef_write_sqme_ref"), .false., & intrinsic = .true., & description=var_str ('Flag that decides whether in the ($\to$) ' // & '\ttt{lhef} event format reference weights of the squared matrix ' // & 'element shall be written in the LHE file. (cf. also \ttt{\$sample}, ' // & '\ttt{sample\_format}, \ttt{lhef}, \ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, ' // & '\ttt{?lhef\_write\_sqme\_prc}, \ttt{?lhef\_write\_sqme\_alt})')) call var_list%append_log (var_str ("?lhef_write_sqme_alt"), .true., & intrinsic = .true., & description=var_str ('Flag that decides whether in the ($\to$) ' // & '\ttt{lhef} event format alternative weights of the squared matrix ' // & 'element shall be written in the LHE file. (cf. also \ttt{\$sample}, ' // & '\ttt{sample\_format}, \ttt{lhef}, \ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, ' // & '\ttt{?lhef\_write\_sqme\_prc}, \ttt{?lhef\_write\_sqme\_ref})')) call var_list%append_string (var_str ("$extension_lha"), var_str ("lha"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_lha ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the (deprecated) LHA format are written. ' // & 'If not set, the default file name and suffix is \ttt{{\em }.lha}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_hepmc"), var_str ("hepmc"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_hepmc ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the HepMC format are written. If not set, ' // & 'the default file name and suffix is \ttt{{\em }.hepmc}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_log (var_str ("?hepmc_output_cross_section"), .false., & intrinsic = .true., & description=var_str ('Flag for the HepMC event format that allows ' // & 'to write out the cross section (and error) from the integration ' // & 'together with each HepMC event. This can be used by programs ' // & 'like Rivet to scale histograms according to the cross section. ' // & '(cf. also \ttt{hepmc})')) call var_list%append_log (var_str ("?hepmc3_write_flows"), .false., & intrinsic = .true., & description=var_str ('Flag for the HepMC3 event format that decides' // & 'whether to write out color flows. The default is \ttt{false}. ' // & '(cf. also \ttt{hepmc})')) call var_list%append_string (var_str ("$hepmc3_mode"), var_str ("HepMC3"), & intrinsic = .true., & description=var_str ('This specifies the writer mode for HepMC3. ' // & 'Possible values are \ttt{HepMC2}, \ttt{HepMC3} (default), ' // & '\ttt{HepEVT}, \ttt{Root}. and \ttt{RootTree} (cf. also \ttt{hepmc})')) call var_list%append_string (var_str ("$extension_lcio"), var_str ("slcio"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_lcio ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the LCIO format are written. If not set, ' // & 'the default file name and suffix is \ttt{{\em }.slcio}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_stdhep"), var_str ("hep"), & intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_stdhep ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the StdHEP format via the HEPEVT common ' // & 'block are written. If not set, the default file name and suffix ' // & 'is \ttt{{\em }.hep}. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample})')) call var_list%append_string (var_str ("$extension_stdhep_up"), & var_str ("up.hep"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_stdhep\_up ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the StdHEP format via the HEPRUP/HEPEUP ' // & 'common blocks are written. \ttt{{\em }.up.hep} ' // & 'is the default file name and suffix, if this variable not set. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_stdhep_ev4"), & var_str ("ev4.hep"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_stdhep\_ev4 ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the StdHEP format via the HEPEVT/HEPEV4 ' // & 'common blocks are written. \ttt{{\em }.up.hep} ' // & 'is the default file name and suffix, if this variable not set. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_hepevt_verb"), & var_str ("hepevt.verb"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_hepevt\_verb ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the \whizard\ version 1 style extended or ' // & 'verbose HEPEVT ASCII format are written. If not set, the default ' // & 'file name and suffix is \ttt{{\em }.hepevt.verb}. ' // & '(cf. also \ttt{sample\_format}, \ttt{\$sample})')) call var_list%append_string (var_str ("$extension_lha_verb"), & var_str ("lha.verb"), intrinsic=.true., & description=var_str ('String variable that allows via \ttt{\$extension\_lha\_verb ' // & '= "{\em }"} to specify the suffix for the file \ttt{name.suffix} ' // & 'to which events in the (deprecated) extended or verbose LHA ' // & 'format are written. If not set, the default file name and suffix ' // & 'is \ttt{{\em }.lha.verb}. (cf. also \ttt{sample\_format}, ' // & '\ttt{\$sample})')) end subroutine var_list_set_eio_defaults @ %def var_list_set_eio_defaults @ <>= procedure :: set_shower_defaults => var_list_set_shower_defaults <>= module subroutine var_list_set_shower_defaults (var_list) class(var_list_t), intent(inout) :: var_list end subroutine var_list_set_shower_defaults <>= module subroutine var_list_set_shower_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_log (var_str ("?allow_shower"), .true., & intrinsic=.true., & description=var_str ('Master flag to switch on (initial and ' // & 'final state) parton shower, matching/merging as an event ' // & 'transform. As a default, it is switched on. (cf. also \ttt{?ps\_ ' // & '....}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?ps_fsr_active"), .false., & intrinsic=.true., & description=var_str ('Flag that switches final-state QCD radiation ' // & '(FSR) on. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, ' // & '\ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?ps_isr_active"), .false., & intrinsic=.true., & description=var_str ('Flag that switches initial-state QCD ' // & 'radiation (ISR) on. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // & '...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?ps_taudec_active"), .false., & intrinsic=.true., & description=var_str ('Flag to switch on $\tau$ decays, at ' // & 'the moment only via the included external package \ttt{TAUOLA} ' // & 'and \ttt{PHOTOS}. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // & '...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?muli_active"), .false., & intrinsic=.true., & description=var_str ("Master flag that switches on \whizard's " // & 'module for multiple interaction with interleaved QCD parton ' // & 'showers for hadron colliders. Note that this feature is still ' // & 'experimental. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // & '...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...})')) call var_list%append_string (var_str ("$shower_method"), var_str ("WHIZARD"), & intrinsic=.true., & description=var_str ('String variable that allows to specify ' // & 'which parton shower is being used, the default, \ttt{"WHIZARD"}, ' // & 'is one of the in-house showers of \whizard. Other possibilities ' // & 'at the moment are only \ttt{"PYTHIA6"}.')) call var_list%append_log (var_str ("?shower_verbose"), .false., & intrinsic=.true., & description=var_str ('Flag to switch on verbose messages when ' // & 'using shower and/or hadronization. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...},')) call var_list%append_string (var_str ("$ps_PYTHIA_PYGIVE"), var_str (""), & intrinsic=.true., & description=var_str ('String variable that allows to pass options ' // & 'for tunes etc. to the attached \pythia\ parton shower or hadronization, ' // & 'e.g.: \ttt{\$ps\_PYTHIA\_PYGIVE = "MSTJ(41)=1"}. (cf. also ' // & '\newline \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_string (var_str ("$ps_PYTHIA8_config"), var_str (""), & intrinsic=.true., & description=var_str ('String variable that allows to pass options ' // & 'for tunes etc. to the attached \pythia\ttt{8} parton shower or hadronization, ' // & 'e.g.: \ttt{\$ps\_PYTHIA8\_config = "PartonLevel:MPI = off"}. (cf. also ' // & '\newline \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_string (var_str ("$ps_PYTHIA8_config_file"), var_str (""), & intrinsic=.true., & description=var_str ('String variable that allows to pass a filename to a ' // & '\pythia\ttt{8} configuration file.')) call var_list%append_real (& var_str ("ps_mass_cutoff"), 1._default, intrinsic = .true., & description=var_str ('Real value that sets the QCD parton shower ' // & 'lower cutoff scale, where hadronization sets in. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (& var_str ("ps_fsr_lambda"), 0.29_default, intrinsic = .true., & description=var_str ('By this real parameter, the value of $\Lambda_{QCD}$ ' // & 'used in running $\alpha_s$ for time-like showers is set (except ' // & 'for showers in the decay of a resonance). (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (& var_str ("ps_isr_lambda"), 0.29_default, intrinsic = .true., & description=var_str ('By this real parameter, the value of $\Lambda_{QCD}$ ' // & 'used in running $\alpha_s$ for space-like showers is set. (cf. ' // & 'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // & '\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_int (& var_str ("ps_max_n_flavors"), 5, intrinsic = .true., & description=var_str ('This integer parameter sets the maxmimum ' // & 'number of flavors that can be produced in a QCD shower $g\to ' // & 'q\bar q$. It is also used as the maximal number of active flavors ' // & 'for the running of $\alpha_s$ in the shower (with a minimum ' // & 'of 3). (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?ps_isr_alphas_running"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether a running ' // & '$\alpha_s$ is taken in space-like QCD parton showers. (cf. ' // & 'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // & '\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?ps_fsr_alphas_running"), .true., & intrinsic=.true., & description=var_str ('Flag that decides whether a running ' // & '$\alpha_s$ is taken in time-like QCD parton showers. (cf. ' // & 'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // & '\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str ("ps_fixed_alphas"), & 0._default, intrinsic = .true., & description=var_str ('This real parameter sets the value of $\alpha_s$ ' // & 'if it is (cf. $\to$ \ttt{?ps\_isr\_alphas\_running}, \newline ' // & '\ttt{?ps\_fsr\_alphas\_running}) not running in initial and/or ' // & 'final-state QCD showers. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // & '...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?ps_isr_pt_ordered"), .false., & intrinsic=.true., & description=var_str ('By this flag, it can be switched between ' // & 'the analytic QCD ISR shower (\ttt{false}, default) and the ' // & '$p_T$ ISR QCD shower (\ttt{true}). (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str ("?ps_isr_angular_ordered"), .true., & intrinsic=.true., & description=var_str ('If switched one, this flag forces opening ' // & 'angles of emitted partons in the QCD ISR shower to be strictly ' // & 'ordered, i.e. increasing towards the hard interaction. (cf. ' // & 'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // & '\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("ps_isr_primordial_kt_width"), 0._default, intrinsic = .true., & description=var_str ('This real parameter sets the width $\sigma ' // & '= \braket{k_T^2}$ for the Gaussian primordial $k_T$ distribution ' // & 'inside the hadron, given by: $\exp[-k_T^2/\sigma^2] k_T dk_T$. ' // & '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("ps_isr_primordial_kt_cutoff"), 5._default, intrinsic = .true., & description=var_str ('Real parameter that sets the upper cutoff ' // & 'for the primordial $k_T$ distribution inside a hadron. (cf. ' // & 'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // & '\ttt{?hadronization\_active}, \ttt{?mlm\_ ...})')) call var_list%append_real (var_str & ("ps_isr_z_cutoff"), 0.999_default, intrinsic = .true., & description=var_str ('This real parameter allows to set the upper ' // & 'cutoff on the splitting variable $z$ in space-like QCD parton ' // & 'showers. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, ' // & '\ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("ps_isr_minenergy"), 1._default, intrinsic = .true., & description=var_str ('By this real parameter, the minimal effective ' // & 'energy (in the c.m. frame) of a time-like or on-shell-emitted ' // & 'parton in a space-like QCD shower is set. For a hard subprocess ' // & 'that is not in the rest frame, this number is roughly reduced ' // & 'by a boost factor $1/\gamma$ to the rest frame of the hard scattering ' // & 'process. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, ' // & '\ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("ps_isr_tscalefactor"), 1._default, intrinsic = .true., & description=var_str ('The $Q^2$ scale of the hard scattering ' // & 'process is multiplied by this real factor to define the maximum ' // & 'parton virtuality allowed in time-like QCD showers. This does ' // & 'only apply to $t$- and $u$-channels, while for $s$-channel resonances ' // & 'the maximum virtuality is set by $m^2$. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_log (var_str & ("?ps_isr_only_onshell_emitted_partons"), .false., intrinsic=.true., & description=var_str ('This flag if set true sets all emitted ' // & 'partons off space-like showers on-shell, i.e. it would not allow ' // & 'associated time-like showers. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})')) end subroutine var_list_set_shower_defaults @ %def var_list_set_shower_defaults @ <>= procedure :: set_hadronization_defaults => var_list_set_hadronization_defaults <>= module subroutine var_list_set_hadronization_defaults (var_list) class(var_list_t), intent(inout) :: var_list end subroutine var_list_set_hadronization_defaults <>= module subroutine var_list_set_hadronization_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_log & (var_str ("?allow_hadronization"), .true., intrinsic=.true., & description=var_str ('Master flag to switch on hadronization ' // & 'as an event transform. As a default, it is switched on. (cf. ' // & 'also \ttt{?ps\_ ....}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, ' // & '\ttt{?hadronization\_active})')) call var_list%append_log & (var_str ("?hadronization_active"), .false., intrinsic=.true., & description=var_str ('Master flag to switch hadronization (through ' // & 'the attached \pythia\ package) on or off. As a default, it is ' // & 'off. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...})')) call var_list%append_string & (var_str ("$hadronization_method"), var_str ("PYTHIA6"), intrinsic = .true., & description=var_str ("Determines whether \whizard's own " // & "hadronization or the (internally included) \pythiasix\ should be used.")) call var_list%append_real & (var_str ("hadron_enhanced_fraction"), 0.01_default, intrinsic = .true., & description=var_str ('Fraction of Lund strings that break with enhanced ' // & 'width. [not yet active]')) call var_list%append_real & (var_str ("hadron_enhanced_width"), 2.0_default, intrinsic = .true., & description=var_str ('Enhancement factor for the width of breaking ' // & 'Lund strings. [not yet active]')) end subroutine var_list_set_hadronization_defaults @ %def var_list_set_hadronization_defaults @ <>= procedure :: set_tauola_defaults => var_list_set_tauola_defaults <>= module subroutine var_list_set_tauola_defaults (var_list) class(var_list_t), intent(inout) :: var_list end subroutine var_list_set_tauola_defaults <>= module subroutine var_list_set_tauola_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_log (& var_str ("?ps_tauola_photos"), .false., intrinsic=.true., & description=var_str ('Flag to switch on \ttt{PHOTOS} for photon ' // & 'showering inside the \ttt{TAUOLA} package. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) call var_list%append_log (& var_str ("?ps_tauola_transverse"), .false., intrinsic=.true., & description=var_str ('Flag to switch transverse $\tau$ polarization ' // & 'on or off for Higgs decays into $\tau$ leptons. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) call var_list%append_log (& var_str ("?ps_tauola_dec_rad_cor"), .true., intrinsic=.true., & description=var_str ('Flag to switch radiative corrections for ' // & '$\tau$ decays in \ttt{TAUOLA} on or off. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) call var_list%append_int (& var_str ("ps_tauola_dec_mode1"), 0, intrinsic = .true., & description=var_str ('Integer code to request a specific $\tau$ ' // & 'decay within \ttt{TAUOLA} for the decaying $\tau$, and -- ' // & 'in correlated decays -- for the second $\tau$. For more information ' // & 'cf. the comments in the code or the \ttt{TAUOLA} manual. ' // & '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) call var_list%append_int (& var_str ("ps_tauola_dec_mode2"), 0, intrinsic = .true., & description=var_str ('Integer code to request a specific $\tau$ ' // & 'decay within \ttt{TAUOLA} for the decaying $\tau$, and -- ' // & 'in correlated decays -- for the second $\tau$. For more information ' // & 'cf. the comments in the code or the \ttt{TAUOLA} manual. ' // & '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) call var_list%append_real (& var_str ("ps_tauola_mh"), 125._default, intrinsic = .true., & description=var_str ('Real option to set the Higgs mass for Higgs ' // & 'decays into $\tau$ leptons in the interface to \ttt{TAUOLA}. ' // & '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) call var_list%append_real (& var_str ("ps_tauola_mix_angle"), 90._default, intrinsic = .true., & description=var_str ('Option to set the mixing angle between ' // & 'scalar and pseudoscalar Higgs bosons for Higgs decays into $\tau$ ' // & 'leptons in the interface to \ttt{TAUOLA}. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) call var_list%append_log (& var_str ("?ps_tauola_pol_vector"), .false., intrinsic = .true., & description=var_str ('Flag to decide whether for transverse $\tau$ ' // & 'polarization, polarization information should be taken from ' // & '\ttt{TAUOLA} or not. The default is just based on random numbers. ' // & '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})')) end subroutine var_list_set_tauola_defaults @ %def var_list_set_tauola_defaults @ <>= procedure :: set_mlm_matching_defaults => var_list_set_mlm_matching_defaults <>= module subroutine var_list_set_mlm_matching_defaults (var_list) class(var_list_t), intent(inout) :: var_list end subroutine var_list_set_mlm_matching_defaults <>= module subroutine var_list_set_mlm_matching_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_log (var_str ("?mlm_matching"), .false., & intrinsic=.true., & description=var_str ('Master flag to switch on MLM (LO) jet ' // & 'matching between hard matrix elements and the QCD parton ' // & 'shower. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, ' // & '\ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_Qcut_ME"), 0._default, intrinsic = .true., & description=var_str ('Real parameter that in the MLM jet matching ' // & 'between hard matrix elements and QCD parton shower sets a possible ' // & 'virtuality cut on jets from the hard matrix element. (cf. also ' // & '\ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ' // & '...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_Qcut_PS"), 0._default, intrinsic = .true., & description=var_str ('Real parameter that in the MLM jet matching ' // & 'between hard matrix elements and QCD parton shower sets a possible ' // & 'virtuality cut on jets from the parton shower. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_ptmin"), 0._default, intrinsic = .true., & description=var_str ('This real parameter sets a minimal $p_T$ ' // & 'that enters the $y_{cut}$ jet clustering measure in the MLM ' // & 'jet matching between hard matrix elements and QCD parton showers. ' // & '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_etamax"), 0._default, intrinsic = .true., & description=var_str ('This real parameter sets a maximal pseudorapidity ' // & 'that enters the MLM jet matching between hard matrix elements ' // & 'and QCD parton showers. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // & '...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_Rmin"), 0._default, intrinsic = .true., & description=var_str ('Real parameter that sets a minimal $R$ ' // & 'distance value that enters the $y_{cut}$ jet clustering measure ' // & 'in the MLM jet matching between hard matrix elements and QCD ' // & 'parton showers. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // & '...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_Emin"), 0._default, intrinsic = .true., & description=var_str ('Real parameter that sets a minimal energy ' // & '$E_{min}$ value as an infrared cutoff in the MLM jet matching ' // & 'between hard matrix elements and QCD parton showers. (cf. also ' // & '\ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ' // & '...}, \ttt{?hadronization\_active})')) call var_list%append_int (var_str & ("mlm_nmaxMEjets"), 0, intrinsic = .true., & description=var_str ('This integer sets the maximal number of ' // & 'jets that are available from hard matrix elements in the MLM ' // & 'jet matching between hard matrix elements and QCD parton shower. ' // & '(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // & '...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_ETclusfactor"), 0.2_default, intrinsic = .true., & description=var_str ('This real parameter is a factor that enters ' // & 'the calculation of the $y_{cut}$ measure for jet clustering ' // & 'after the parton shower in the MLM jet matching between hard ' // & 'matrix elements and QCD parton showers. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_ETclusminE"), 5._default, intrinsic = .true., & description=var_str ('This real parameter is a minimal energy ' // & 'that enters the calculation of the $y_{cut}$ measure for jet ' // & 'clustering after the parton shower in the MLM jet matching between ' // & 'hard matrix elements and QCD parton showers. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_etaclusfactor"), 1._default, intrinsic = .true., & description=var_str ('This real parameter is a factor that enters ' // & 'the calculation of the $y_{cut}$ measure for jet clustering ' // & 'after the parton shower in the MLM jet matching between hard ' // & 'matrix elements and QCD parton showers. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_Rclusfactor"), 1._default, intrinsic = .true., & description=var_str ('This real parameter is a factor that enters ' // & 'the calculation of the $y_{cut}$ measure for jet clustering ' // & 'after the parton shower in the MLM jet matching between hard ' // & 'matrix elements and QCD parton showers. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) call var_list%append_real (var_str & ("mlm_Eclusfactor"), 1._default, intrinsic = .true., & description=var_str ('This real parameter is a factor that enters ' // & 'the calculation of the $y_{cut}$ measure for jet clustering ' // & 'after the parton shower in the MLM jet matching between hard ' // & 'matrix elements and QCD parton showers. (cf. also \ttt{?allow\_shower}, ' // & '\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})')) end subroutine var_list_set_mlm_matching_defaults @ %def var_list_set_mlm_matching_defaults @ <>= procedure :: set_powheg_matching_defaults => & var_list_set_powheg_matching_defaults <>= module subroutine var_list_set_powheg_matching_defaults (var_list) class(var_list_t), intent(inout) :: var_list end subroutine var_list_set_powheg_matching_defaults <>= module subroutine var_list_set_powheg_matching_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_log (var_str ("?powheg_matching"), & .false., intrinsic = .true., & description=var_str ('Activates Powheg matching. Needs to be ' // & 'combined with the \ttt{?combined\_nlo\_integration}-method.')) call var_list%append_log (var_str ("?powheg_use_singular_jacobian"), & .false., intrinsic = .true., & description=var_str ('This allows to give a different ' // & 'normalization of the Jacobian, resulting in an alternative ' // & 'POWHEG damping in the singular regions.')) call var_list%append_int (var_str ("powheg_grid_size_xi"), & 5, intrinsic = .true., & description=var_str ('Number of $\xi$ points in the POWHEG grid.')) call var_list%append_int (var_str ("powheg_grid_size_y"), & 5, intrinsic = .true., & description=var_str ('Number of $y$ points in the POWHEG grid.')) call var_list%append_real (var_str ("powheg_pt_min"), & 1._default, intrinsic = .true., & description=var_str ('Lower $p_T$-cut-off for the POWHEG ' // & 'hardest emission.')) call var_list%append_real (var_str ("powheg_lambda"), & LAMBDA_QCD_REF, intrinsic = .true., & description=var_str ('Reference scale of the $\alpha_s$ evolution ' // & 'in the POWHEG matching algorithm.')) call var_list%append_log (var_str ("?powheg_test_sudakov"), & .false., intrinsic = .true., & description=var_str ('Performs an internal consistency check ' // & 'on the POWHEG event generation.')) call var_list%append_log (var_str ("?powheg_disable_sudakov"), & .false., intrinsic = .true., & description=var_str ('This flag allows to set the Sudakov form ' // & 'factor to one. This effectively results in a version of ' // & 'the matrix-element method (MEM) at NLO.')) end subroutine var_list_set_powheg_matching_defaults @ %def var_list_set_powheg_matching_defaults @ <>= procedure :: set_openmp_defaults => var_list_set_openmp_defaults <>= module subroutine var_list_set_openmp_defaults (var_list) class(var_list_t), intent(inout) :: var_list end subroutine var_list_set_openmp_defaults <>= module subroutine var_list_set_openmp_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_log (var_str ("?omega_openmp"), & openmp_is_active (), & intrinsic=.true., & description=var_str ('Flag to switch on or off OpenMP multi-threading ' // & "for \oMega\ matrix elements. (cf. also \ttt{\$method}, \ttt{\$omega\_flag})")) call var_list%append_log (var_str ("?openmp_is_active"), & openmp_is_active (), & locked=.true., intrinsic=.true., & description=var_str ('Flag to switch on or off OpenMP multi-threading ' // & 'for \whizard. (cf. also \ttt{?openmp\_logging}, \ttt{openmp\_num\_threads}, ' // & '\ttt{openmp\_num\_threads\_default}, \ttt{?omega\_openmp})')) call var_list%append_int (var_str ("openmp_num_threads_default"), & openmp_get_default_max_threads (), & locked=.true., intrinsic=.true., & description=var_str ('Integer parameter that shows the number ' // & 'of default OpenMP threads for multi-threading. Note that this ' // & 'parameter can only be accessed, but not reset by the user. (cf. ' // & 'also \ttt{?openmp\_logging}, \ttt{openmp\_num\_threads}, \ttt{?omega\_openmp})')) call var_list%append_int (var_str ("openmp_num_threads"), & openmp_get_max_threads (), & intrinsic=.true., & description=var_str ('Integer parameter that sets the number ' // & 'of OpenMP threads for multi-threading. (cf. also \ttt{?openmp\_logging}, ' // & '\ttt{openmp\_num\_threads\_default}, \ttt{?omega\_openmp})')) call var_list%append_log (var_str ("?openmp_logging"), & .true., intrinsic=.true., & description=var_str ('This logical -- when set to \ttt{false} ' // & '-- suppresses writing out messages about OpenMP parallelization ' // & '(number of used threads etc.) on screen and into the logfile ' // & '(default name \ttt{whizard.log}) for the whole \whizard\ run. ' // & 'Mainly for debugging purposes. (cf. also \ttt{?logging}, ' // & '\ttt{?mpi\_logging})')) end subroutine var_list_set_openmp_defaults @ %def var_list_set_openmp_defaults @ <>= procedure :: set_mpi_defaults => var_list_set_mpi_defaults <>= module subroutine var_list_set_mpi_defaults (var_list) class(var_list_t), intent(inout) :: var_list end subroutine var_list_set_mpi_defaults <>= module subroutine var_list_set_mpi_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_log (var_str ("?mpi_logging"), & .false., intrinsic=.true., & description=var_str('This logical -- when set to \ttt{false} ' // & '-- suppresses writing out messages about MPI parallelization ' // & '(number of used workers etc.) on screen and into the logfile ' // & '(default name \ttt{whizard.log}) for the whole \whizard\ run. ' // & 'Mainly for debugging purposes. (cf. also \ttt{?logging}, ' // & '\ttt{?openmp\_logging})')) end subroutine var_list_set_mpi_defaults @ %def var_list_set_mpi_defaults @ <>= procedure :: set_nlo_defaults => var_list_set_nlo_defaults <>= module subroutine var_list_set_nlo_defaults (var_list) class(var_list_t), intent(inout) :: var_list end subroutine var_list_set_nlo_defaults <>= module subroutine var_list_set_nlo_defaults (var_list) class(var_list_t), intent(inout) :: var_list call var_list%append_string (var_str ("$born_me_method"), & var_str (""), intrinsic = .true., & description=var_str ("This string variable specifies the method " // & "for the matrix elements to be used in the evaluation of the " // & "Born part of the NLO computation. The default is the empty string, " // & "i.e. the \ttt{\$method} being the intrinsic \oMega\ matrix element " // & 'generator (\ttt{"omega"}), other options ' // & 'are: \ttt{"ovm"}, \ttt{"unit\_test"}, \ttt{"template"}, ' // & '\ttt{"template\_unity"}, \ttt{"threshold"}, \ttt{"gosam"}, ' // & '\ttt{"openloops"}. Note that this option is inoperative if ' // & 'no NLO calculation is specified in the process definition. ' // & 'If you want ot use different matrix element methods in a LO ' // & 'computation, use the usual \ttt{method} command. (cf. also ' // & '\ttt{\$correlation\_me\_method}, ' // & '\ttt{\$dglap\_me\_method}, \ttt{\$loop\_me\_method} and ' // & '\ttt{\$real\_tree\_me\_method}.)')) call var_list%append_string (var_str ("$loop_me_method"), & var_str (""), intrinsic = .true., & description=var_str ('This string variable specifies the method ' // & 'for the matrix elements to be used in the evaluation of the ' // & 'virtual part of the NLO computation. The default is the empty string, ' // & 'i.e. the same as \ttt{\$method}. Working options are: ' // & '\ttt{"threshold"}, \ttt{"openloops"}, \ttt{"recola"}, \ttt{"gosam"}. ' // & '(cf. also \ttt{\$real\_tree\_me\_method}, \ttt{\$correlation\_me\_method} ' // & 'and \ttt{\$born\_me\_method}.)')) call var_list%append_string (var_str ("$correlation_me_method"), & var_str (""), intrinsic = .true., & description=var_str ('This string variable specifies ' // & 'the method for the matrix elements to be used in the evaluation ' // & 'of the color (and helicity) correlated part of the NLO computation. ' // & "The default is the same as the \ttt{\$method}, i.e. the intrinsic " // & "\oMega\ matrix element generator " // & '(\ttt{"omega"}), other options are: \ttt{"ovm"}, \ttt{"unit\_test"}, ' // & '\ttt{"template"}, \ttt{"template\_unity"}, \ttt{"threshold"}, ' // & '\ttt{"gosam"}, \ttt{"openloops"}. (cf. also ' // & '\ttt{\$born\_me\_method}, \ttt{\$dglap\_me\_method}, ' // & '\ttt{\$loop\_me\_method} and \newline' // & '\ttt{\$real\_tree\_me\_method}.)')) call var_list%append_string (var_str ("$real_tree_me_method"), & var_str (""), intrinsic = .true., & description=var_str ('This string variable specifies the method ' // & 'for the matrix elements to be used in the evaluation of the ' // & 'real part of the NLO computation. The default is the same as ' // & 'the \ttt{\$method}, i.e. the intrinsic ' // & "\oMega\ matrix element generator " // & '(\ttt{"omega"}), other options ' // & 'are: \ttt{"ovm"}, \ttt{"unit\_test"}, \ttt{"template"}, \ttt{"template\_unity"}, ' // & '\ttt{"threshold"}, \ttt{"gosam"}, \ttt{"openloops"}. (cf. also ' // & '\ttt{\$born\_me\_method}, \ttt{\$correlation\_me\_method}, ' // & '\ttt{\$dglap\_me\_method} and \ttt{\$loop\_me\_method}.)')) call var_list%append_string (var_str ("$dglap_me_method"), & var_str (""), intrinsic = .true., & description=var_str ('This string variable specifies the method ' // & 'for the matrix elements to be used in the evaluation of the ' // & 'DGLAP remnants of the NLO computation. The default is the same as ' // & "\ttt{\$method}, i.e. the \oMega\ matrix element generator " // & '(\ttt{"omega"}), other options ' // & 'are: \ttt{"ovm"}, \ttt{"unit\_test"}, \ttt{"template"}, \ttt{"template\_unity"}, ' // & '\ttt{"threshold"}, \ttt{"gosam"}, \ttt{"openloops"}. (cf. also \newline' // & '\ttt{\$born\_me\_method}, \ttt{\$correlation\_me\_method}, ' // & '\ttt{\$loop\_me\_method} and \ttt{\$real\_tree\_me\_method}.)')) call var_list%append_log (& var_str ("?test_soft_limit"), .false., intrinsic = .true., & description=var_str ('Sets the fixed values $\tilde{\xi} = 0.00001$ ' // & 'and $y = 0.5$ as radiation variables. This way, only soft, ' // & 'but non-collinear phase space points are generated, which allows ' // & 'for testing subtraction in this region.')) call var_list%append_log (& var_str ("?test_coll_limit"), .false., intrinsic = .true., & description=var_str ('Sets the fixed values $\tilde{\xi} = 0.5$ ' // & 'and $y = 0.9999999$ as radiation variables. This way, only collinear, ' // & 'but non-soft phase space points are generated, which allows ' // & 'for testing subtraction in this region. Can be combined with ' // & '\ttt{?test\_soft\_limit} to probe soft-collinear regions.')) call var_list%append_log (& var_str ("?test_anti_coll_limit"), .false., intrinsic = .true., & description=var_str ('Sets the fixed values $\tilde{\xi} = 0.5$ ' // & 'and $y = -0.9999999$ as radiation variables. This way, only anti-collinear, ' // & 'but non-soft phase space points are generated, which allows ' // & 'for testing subtraction in this region. Can be combined with ' // & '\ttt{?test\_soft\_limit} to probe soft-collinear regions.')) call var_list%append_string (var_str ("$select_alpha_regions"), & var_str (""), intrinsic = .true., & description=var_str ('Fixes the $\alpha_r$ in the real ' // & 'subtraction as well as the DGLAP component. Allows for ' // & 'testing in a list of selected singular regions.')) call var_list%append_string (var_str ("$virtual_selection"), & var_str ("Full"), intrinsic = .true., & description=var_str ('String variable to select either the full ' // & 'or only parts of the virtual components of an NLO calculation. ' // & 'Possible modes are \ttt{"Full"}, \ttt{"OLP"} and ' // & '\ttt{"Subtraction."}. Mainly for debugging purposes.')) call var_list%append_log (var_str ("?virtual_collinear_resonance_aware"), & .true., intrinsic = .true., & description=var_str ('This flag allows to switch between two ' // & 'different implementations of the collinear subtraction in the ' // & 'resonance-aware FKS setup.')) call var_list%append_real (& var_str ("blha_top_yukawa"), -1._default, intrinsic = .true., & description=var_str ('If this value is set, the given value will ' // & 'be used as the top Yukawa coupling instead of the top mass. ' // & 'Note that having different values for $y_t$ and $m_t$ must be ' // & 'supported by your OLP-library and yield errors if this is not the case.')) call var_list%append_string (var_str ("$blha_ew_scheme"), & var_str ("alpha_internal"), intrinsic = .true., & description=var_str ('String variable that transfers the electroweak ' // & 'renormalization scheme via BLHA to the one-loop provider. Possible ' // & 'values are \ttt{GF} or \ttt{Gmu} for the $G_\mu$ scheme, ' // & '\ttt{alpha\_internal} (default, $G_\mu$ scheme, but value of ' // & '$\alpha_S$ calculated internally by \whizard), \ttt{alpha\_mz} ' // & 'and \ttt{alpha\_0} (or \ttt{alpha\_thompson}) for different schemes ' // & 'with $\alpha$ as input.')) call var_list%append_int (var_str ("openloops_verbosity"), 1, & intrinsic = .true., & description=var_str ('Decides how much \openloops\ output is printed. ' // & 'Can have values 0, 1 and 2, where 2 is the highest verbosity level.')) call var_list%append_log (var_str ("?openloops_use_cms"), & .true., intrinsic = .true., & description=var_str ('Activates the complex mass scheme in ' // & '\openloops. (cf. also ' // & '\ttt{openloos\_verbosity}, \ttt{\$method}, ' // & '\ttt{?openloops\_switch\_off\_muon\_yukawa}, ' // & '\ttt{openloops\_stability\_log}, \newline' // & '\ttt{\$openloops\_extra\_cmd})')) call var_list%append_int (var_str ("openloops_phs_tolerance"), 7, & intrinsic = .true., & description=var_str ('This integer parameter gives via ' // & '\ttt{openloops\_phs\_tolerance = } the relative numerical ' // & 'tolerance $10^{-n}$ for the momentum conservation of the ' // & 'external particles within \openloops. (cf. also ' // & '\ttt{openloos\_verbosity}, \ttt{\$method}, ' // & '\ttt{?openloops\_switch\_off\_muon\_yukawa}, ' // & '\newline\ttt{openloops\_stability\_log}, ' // & '\ttt{\$openloops\_extra\_cmd})')) call var_list%append_int (var_str ("openloops_stability_log"), 0, & intrinsic = .true., & description=var_str ('Creates the directory \ttt{stability\_log} ' // & 'containing information about the performance of the \openloops ' // & 'matrix elements. Possible values are 0 (No output), 1 (On ' // & '\ttt{finish()}-call), 2 (Adaptive) and 3 (Always).')) call var_list%append_log (var_str ("?openloops_switch_off_muon_yukawa"), & .false., intrinsic = .true., & description=var_str ('Sets the Yukawa coupling of muons for ' // & '\openloops\ to zero. (cf. also ' // & '\ttt{openloos\_verbosity}, \ttt{\$method}, ' // & '\ttt{?openloops\_use\_cms}, \ttt{openloops\_stability\_log}, ' // & '\ttt{\$openloops\_extra\_cmd})')) call var_list%append_string (var_str ("$openloops_extra_cmd"), & var_str (""), intrinsic = .true., & description=var_str ('String variable to transfer customized ' // & 'special commands to \openloops. The three supported examples ' // & '\ttt{\$openloops\_extra\_command = "extra approx top/stop/not"} ' // & 'are for selection of subdiagrams in top production. (cf. also ' // & '\ttt{\$method}, \ttt{openloos\_verbosity}, ' // & '\ttt{?openloops\_use\_cms}, \ttt{openloops\_stability\_log}, ' // & '\ttt{?openloops\_switch\_off\_muon\_yukawa})')) call var_list%append_real (var_str ("ellis_sexton_scale"), & -1._default, intrinsic = .true., & description = var_str ('Real positive paramter for the Ellis-Sexton scale' // & '$\mathcal{Q}$ used both in the finite one-loop contribution provided by' // & 'the OLP and in the virtual counter terms. The NLO cross section is' // & 'independent of $\mathcal{Q}$. Therefore, this allows for debugging of' // & 'the implemention of the virtual counter terms. As the default' // & '$\mathcal{Q} = \mu_{\rm{R}}$ is chosen. So far, setting this parameter' // & 'only works for OpenLoops2, otherwise the default behaviour is invoked.')) call var_list%append_log (var_str ("?disable_subtraction"), & .false., intrinsic = .true., & description=var_str ('Disables the subtraction of soft and collinear ' // & 'divergences from the real matrix element.')) call var_list%append_real (var_str ("fks_dij_exp1"), & 1._default, intrinsic = .true., & description=var_str ('Fine-tuning parameters of the FKS ' // & 'final state partition functions. The exact meaning depends ' // & 'on the mapping implementation. (cf. also \ttt{fks\_dij\_exp2}, ' // & '\ttt{\$fks\_mapping\_type}, \ttt{fks\_xi\_min}, \ttt{fks\_y\_max})')) call var_list%append_real (var_str ("fks_dij_exp2"), & 1._default, intrinsic = .true., & description=var_str ('Fine-tuning parameters of the FKS ' // & 'initial state partition functions. The exact meaning depends ' // & 'on the mapping implementation. (cf. also \ttt{fks\_dij\_exp1}, ' // & '\ttt{\$fks\_mapping\_type}, \ttt{fks\_xi\_min}, \ttt{fks\_y\_max})')) call var_list%append_real (var_str ("fks_xi_min"), & 0._default, intrinsic = .true., & description=var_str ('Real parameter for the FKS ' // & 'phase space that sets the numerical lower value of the $\xi$ ' // & 'variable. Valid for the value range $[\texttt{tiny\_07},1]$, where ' // & 'value inputs out of bounds will take the value of the closest bound. ' // & 'Here, $\texttt{tiny\_07} = \texttt{1E0\_default * epsilon (0.\_default)}$, where ' // & '\ttt{epsilon} is an intrinsic Fortran function. (cf. also \ttt{fks\_dij\_exp1}, ' // & '\ttt{fks\_dij\_exp2}, \ttt{\$fks\_mapping\_type}, \ttt{fks\_y\_max})')) call var_list%append_real (var_str ("fks_y_max"), & 1._default, intrinsic = .true., & description=var_str ('Real parameter for the FKS ' // & 'phase space that sets the numerical upper value of the $\left|y\right|$ ' // & 'variable. Valid for ranges $[0,1]$, where value inputs out of bounds will take ' // & 'the value of the closest bound. Only supported for massless FSR. ' // & '(cf. also \ttt{fks\_dij\_exp1}, \ttt{\$fks\_mapping\_type}, \ttt{fks\_dij\_exp2})')) call var_list%append_log (var_str ("?vis_fks_regions"), & .false., intrinsic = .true., & description=var_str ('Logical variable that, if set to ' // & '\ttt{true}, generates \LaTeX\ code and executes it into a PDF ' // & ' to produce a table of all singular FKS regions and their ' // & ' flavor structures. The default is \ttt{false}.')) call var_list%append_real (var_str ("fks_xi_cut"), & 1.0_default, intrinsic = .true., & description = var_str ('(Experimental) Real parameter for the FKS ' // & 'phase space that applies a cut to $\xi$ variable with $0 < \xi_{\text{cut}}' // & '\leq \xi_{\text{max}}$. The dependence on the parameter vanishes between ' // & 'real subtraction and integrated subtraction term. Could thus be used for debugging. ' // & 'This is not implemented properly, use at your own risk!')) call var_list%append_real (var_str ("fks_delta_o"), & 2._default, intrinsic = .true., & description = var_str ('Real parameter for the FKS ' // & 'phase space that applies a cut to the $y$ variable with $0 < \delta_o \leq 2$ ' // & 'for final state singularities only. ' // & 'The dependence on the parameter vanishes between real subtraction and integrated ' // & 'subtraction term. For debugging purposes.')) call var_list%append_real (var_str ("fks_delta_i"), & 2._default, intrinsic = .true., & description = var_str ('Real parameter for the FKS ' // & 'phase space that applies a cut to the $y$ variable with ' // & '$0 < \delta_{\mathrm{I}} \leq 2$ '// & 'for initial state singularities only. ' // & 'The dependence on the parameter vanishes between real subtraction and integrated ' // & 'subtraction term. For debugging purposes.')) call var_list%append_string (var_str ("$fks_mapping_type"), & var_str ("default"), intrinsic = .true., & description=var_str ('Sets the FKS mapping type. Possible values ' // & 'are \ttt{"default"} and \ttt{"resonances"}. The latter option ' // & 'activates the resonance-aware subtraction mode and induces the ' // & 'generation of a soft mismatch component. (cf. also ' // & '\ttt{fks\_dij\_exp1}, \ttt{fks\_dij\_exp2}, \ttt{fks\_xi\_min}, ' // & '\ttt{fks\_y\_max})')) call var_list%append_string (var_str ("$resonances_exclude_particles"), & var_str ("default"), intrinsic = .true., & description=var_str ('Accepts a string of particle names. These ' // & 'particles will be ignored when the resonance histories are generated. ' // & 'If \ttt{\$fks\_mapping\_type} is not \ttt{"resonances"}, this ' // & 'option does nothing.')) call var_list%append_int (var_str ("alpha_power"), & 2, intrinsic = .true., & description=var_str ('Fixes the electroweak coupling ' // & 'powers used by BLHA matrix element generators. Setting these ' // & 'values is necessary for the correct generation of OLP-files. ' // & 'Having inconsistent values yields to error messages by the corresponding ' // & 'OLP-providers.')) call var_list%append_int (var_str ("alphas_power"), & 0, intrinsic = .true., & description=var_str ('Fixes the strong coupling ' // & 'powers used by BLHA matrix element generators. Setting these ' // & 'values is necessary for the correct generation of OLP-files. ' // & 'Having inconsistent values yields to error messages by the corresponding ' // & 'OLP-providers.')) call var_list%append_log (var_str ("?combined_nlo_integration"), & .false., intrinsic = .true., & description=var_str ('When this option is set to \ttt{true}, ' // & 'the NLO integration will not be performed in the separate components, ' // & 'but instead the sum of all components will be integrated directly. ' // & 'When fixed-order NLO events are requested, this integration ' // & 'mode is possible, but not necessary. However, it is necessary ' // & 'for POWHEG events.')) call var_list%append_log (var_str ("?fixed_order_nlo_events"), & .false., intrinsic = .true., & description=var_str ('Induces the generation of fixed-order ' // & 'NLO events.')) call var_list%append_log (var_str ("?check_event_weights_against_xsection"), & .false., intrinsic = .true., & description=var_str ('Activates an internal recording of event ' // & 'weights when unweighted events are generated. At the end of ' // & 'the simulation, the mean value of the weights and its standard ' // & 'deviation are displayed. This allows to cross-check event generation ' // & 'and integration, because the value displayed must be equal to ' // & 'the integration result.')) call var_list%append_log (var_str ("?keep_failed_events"), & .false., intrinsic = .true., & description=var_str ('In the context of weighted event generation, ' // & 'if set to \ttt{true}, events with failed kinematics will be ' // & 'written to the event output with an associated weight of zero. ' // & 'This way, the total cross section can be reconstructed from the event output.')) call var_list%append_int (var_str ("gks_multiplicity"), & 0, intrinsic = .true., & description=var_str ('Jet multiplicity for the GKS merging scheme.')) call var_list%append_string (var_str ("$gosam_filter_lo"), & var_str (""), intrinsic = .true., & description=var_str ('The filter string given to \gosam\ in order to ' // & 'filter out tree-level diagrams. (cf. also \ttt{\$gosam\_filter\_nlo}, ' // & '\ttt{\$gosam\_symmetries})')) call var_list%append_string (var_str ("$gosam_filter_nlo"), & var_str (""), intrinsic = .true., & description=var_str ('The same as \ttt{\$gosam\_filter\_lo}, but for ' // & 'loop matrix elements. (cf. also \ttt{\$gosam\_filter\_nlo}, ' // & '\ttt{\$gosam\_symmetries})')) call var_list%append_string (var_str ("$gosam_symmetries"), & var_str ("family,generation"), intrinsic = .true., & description=var_str ('String variable that is transferred to \gosam\ ' // & 'configuration file to determine whether certain helicity configurations ' // & 'are considered to be equal. Possible values are \ttt{flavour}, ' // & '\ttt{family} etc. For more info see the \gosam\ manual.')) call var_list%append_int (var_str ("form_threads"), & 2, intrinsic = .true., & description=var_str ('The number of threads used by \gosam\ when ' // & 'matrix elements are evaluated using \ttt{FORM}')) call var_list%append_int (var_str ("form_workspace"), & 1000, intrinsic = .true., & description=var_str ('The size of the workspace \gosam\ requires ' // & 'from \ttt{FORM}. Inside \ttt{FORM}, it corresponds to the heap ' // & 'size used by the algebra processor.')) call var_list%append_string (var_str ("$gosam_fc"), & var_str (""), intrinsic = .true., & description=var_str ('The Fortran compiler used by \gosam.')) call var_list%append_real (& var_str ("mult_call_real"), 1._default, & intrinsic = .true., & description=var_str ('(Real-valued) multiplier for the number ' // & 'of calls used in the integration of the real subtraction ' // & 'NLO component. This way, a higher accuracy can be achieved for ' // & 'the real component, while simultaneously avoiding redundant ' // & 'integration calls for the other components. (cf. also ' // & '\ttt{mult\_call\_dglap}, \ttt{mult\_call\_virt})')) call var_list%append_real (& var_str ("mult_call_virt"), 1._default, & intrinsic = .true., & description=var_str ('(Real-valued) multiplier for the number ' // & 'of calls used in the integration of the virtual NLO ' // & 'component. This way, a higher accuracy can be achieved for ' // & 'this component, while simultaneously avoiding redundant ' // & 'integration calls for the other components. (cf. also ' // & '\ttt{mult\_call\_dglap}, \ttt{mult\_call\_real})')) call var_list%append_real (& var_str ("mult_call_dglap"), 1._default, & intrinsic = .true., & description=var_str ('(Real-valued) multiplier for the number ' // & 'of calls used in the integration of the DGLAP remnant NLO ' // & 'component. This way, a higher accuracy can be achieved for ' // & 'this component, while simultaneously avoiding redundant ' // & 'integration calls for the other components. (cf. also ' // & '\ttt{mult\_call\_real}, \ttt{mult\_call\_virt})')) call var_list%append_string (var_str ("$dalitz_plot"), & var_str (''), intrinsic = .true., & description=var_str ('This string variable has two purposes: ' // & 'when different from the empty string, it switches on generation ' // & 'of the Dalitz plot file (ASCII tables) for the real emitters. ' // & 'The string variable itself provides the file name.')) call var_list%append_string (var_str ("$nlo_correction_type"), & var_str ("QCD"), intrinsic = .true., & description=var_str ('String variable which sets the NLO correction ' // & 'type via \ttt{nlo\_correction\_type = "{\em }"} to either ' // & '\ttt{"QCD"}, \ttt{"EW"}, or to all with \ttt{\em{}} ' // & 'set to \ttt{"Full"}. Must be set before the \texttt{process} statement.')) call var_list%append_string (var_str ("$exclude_gauge_splittings"), & var_str ("c:b:t:e2:e3"), intrinsic = .true., & description=var_str ('String variable that allows via ' // & '\ttt{\$exclude\_gauge\_splittings = "{\em ::\dots}"} ' // & 'to exclude fermion flavors from gluon/photon splitting into ' // & 'fermion pairs beyond LO. For example \ttt{\$exclude\_gauge\_splittings ' // & '= "c:s:b:t"} would lead to \ttt{gl => u U} and \ttt{gl => d ' // & 'D} as possible splittings in QCD. It is important to keep in ' // & 'mind that only the particles listed in the string are excluded! ' // & 'In QED this string would additionally allow for all splittings into ' // & 'lepton pairs \ttt{A => l L}. Therefore, once set the variable ' // & 'acts as a replacement of the default value, not as an addition! ' // & 'Note: \ttt{"\em "} can be both particle or antiparticle. It ' // & 'will always exclude the corresponding fermion pair. An empty ' // & 'string allows for all fermion flavors to take part in the splitting! ' // & 'Also, particles included in an \ttt{alias} are not excluded by ' // & '\ttt{\$exclude\_gauge\_splittings}!')) call var_list%append_log (var_str ("?nlo_use_born_scale"), & .false., intrinsic = .true., & description=var_str ('Flag that decides whether a scale expression ' // & 'defined for the Born component of an NLO process shall be applied ' // & 'to all other components as well or not. ' // & '(cf. also \ttt{?nlo\_cut\_all\_real\_sqmes})')) call var_list%append_log (var_str ("?nlo_cut_all_real_sqmes"), & .false., intrinsic = .true., & description=var_str ('Flag that decides whether in the case that ' // & 'the real component does not pass a cut, its subtraction term ' // & 'shall be discarded for that phase space point as well or not. ' // & '(cf. also \ttt{?nlo\_use\_born\_scale})')) call var_list%append_string (var_str ("$real_partition_mode"), var_str ("default"), & intrinsic=.true., & description=var_str ('String variable to choose which parts of the real cross ' // & 'section are to be integrated. With the default value (\ttt{"default"}) ' // & 'or \ttt{"off"} the real cross section is integrated as usual without partition. ' // & 'If set to \ttt{"on"} or \ttt{"all"}, the real cross section is split into singular ' // & 'and finite part using a partition function $F$, such that $\mathcal{R} ' // & '= [1-F(p_T^2)]\mathcal{R} + F(p_T^2)\mathcal{R} = \mathcal{R}_{\text{fin}} ' // & '+ \mathcal{R}_{\text{sing}}$. The emission generation is then performed ' // & 'using $\mathcal{R}_{\text{sing}}$, whereas $\mathcal{R}_{\text{fin}}$ ' // & 'is treated separately. If set to \ttt{"singular"} (\ttt{"finite"}), ' // & 'only the singular (finite) real component is integrated.' // & '(cf. also \ttt{real\_partition\_scale})')) call var_list%append_real (var_str ("real_partition_scale"), & 10._default, intrinsic = .true., & description=var_str ('This real variable sets the invariant mass ' // & 'of the FKS pair used as a separator between the singular and the ' // & 'finite part of the real subtraction terms in an NLO calculation, ' // & 'e.g. in $e^+e^- \to t\bar tj$. (cf. also \ttt{\$real\_partition\_mode})')) call var_list%append_log (var_str ("?nlo_reuse_amplitudes_fks"), & .false., intrinsic = .true., & description=var_str ('Only compute real and virtual amplitudes for ' // & 'subprocesses that give a different amplitude and reuse the result ' // & 'for equivalent subprocesses. ' // & 'Might give a speed-up for some processes. Might ' // & 'break others, especially in cases where resonance histories are needed. ' // & 'Experimental feature, use at your own risk!')) end subroutine var_list_set_nlo_defaults @ %def var_list_set_nlo_defaults @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Observables} In this module we define concrete variables and operators (observables) that we want to support in expressions. <<[[observables.f90]]>>= <> module observables <> <> use subevents use variables <> <> interface <> end interface end module observables @ %def observables @ <<[[observables_sub.f90]]>>= <> submodule (observables) observables_s use io_units use diagnostics use lorentz implicit none contains <> end submodule observables_s @ %def observables_s @ \subsection{Observables} These are analogous to the unary and binary numeric functions listed above. An observable takes the [[pval]] component(s) of its one or two argument nodes and produces an integer or real value. \subsubsection{Integer-valued unary observables} The PDG code <>= integer function obs_pdg1 (prt1) result (pdg) type(prt_t), intent(in) :: prt1 pdg = prt_get_pdg (prt1) end function obs_pdg1 @ %def obs_pdg @ The helicity. The return value is meaningful only if the particle is polarized, otherwise an invalid value is returned (-9). <>= integer function obs_helicity1 (prt1) result (h) type(prt_t), intent(in) :: prt1 if (prt_is_polarized (prt1)) then h = prt_get_helicity (prt1) else h = -9 end if end function obs_helicity1 @ %def obs_helicity1 @ The number of open color (anticolor) lines. The return value is meaningful only if the particle is colorized (i.e., the subevent has been given color information), otherwise the function returns zero. <>= integer function obs_n_col1 (prt1) result (n) type(prt_t), intent(in) :: prt1 if (prt_is_colorized (prt1)) then n = prt_get_n_col (prt1) else n = 0 end if end function obs_n_col1 integer function obs_n_acl1 (prt1) result (n) type(prt_t), intent(in) :: prt1 if (prt_is_colorized (prt1)) then n = prt_get_n_acl (prt1) else n = 0 end if end function obs_n_acl1 @ %def obs_n_col1 @ %def obs_n_acl1 @ \subsubsection{Real-valued unary observables} The invariant mass squared, obtained from the separately stored value. <>= real(default) function obs_mass_squared1 (prt1) result (p2) type(prt_t), intent(in) :: prt1 p2 = prt_get_msq (prt1) end function obs_mass_squared1 @ %def obs_mass_squared1 @ The signed invariant mass, which is the signed square root of the previous observable. <>= real(default) function obs_signed_mass1 (prt1) result (m) type(prt_t), intent(in) :: prt1 real(default) :: msq msq = prt_get_msq (prt1) m = sign (sqrt (abs (msq)), msq) end function obs_signed_mass1 @ %def obs_signed_mass1 @ The particle energy <>= real(default) function obs_energy1 (prt1) result (e) type(prt_t), intent(in) :: prt1 e = energy (prt_get_momentum (prt1)) end function obs_energy1 @ %def obs_energy1 @ Particle momentum (components) <>= real(default) function obs_px1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = vector4_get_component (prt_get_momentum (prt1), 1) end function obs_px1 real(default) function obs_py1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = vector4_get_component (prt_get_momentum (prt1), 2) end function obs_py1 real(default) function obs_pz1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = vector4_get_component (prt_get_momentum (prt1), 3) end function obs_pz1 real(default) function obs_p1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = space_part_norm (prt_get_momentum (prt1)) end function obs_p1 real(default) function obs_pl1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = longitudinal_part (prt_get_momentum (prt1)) end function obs_pl1 real(default) function obs_pt1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = transverse_part (prt_get_momentum (prt1)) end function obs_pt1 @ %def obs_px1 obs_py1 obs_pz1 @ %def obs_p1 obs_pl1 obs_pt1 @ Polar and azimuthal angle (lab frame). <>= real(default) function obs_theta1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = polar_angle (prt_get_momentum (prt1)) end function obs_theta1 real(default) function obs_phi1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = azimuthal_angle (prt_get_momentum (prt1)) end function obs_phi1 @ %def obs_theta1 obs_phi1 @ Rapidity and pseudorapidity <>= real(default) function obs_rap1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = rapidity (prt_get_momentum (prt1)) end function obs_rap1 real(default) function obs_eta1 (prt1) result (p) type(prt_t), intent(in) :: prt1 p = pseudorapidity (prt_get_momentum (prt1)) end function obs_eta1 @ %def obs_rap1 obs_eta1 @ Meaningless: Polar angle in the rest frame of the two arguments combined. <>= real(default) function obs_theta_star1 (prt1) result (dist) type(prt_t), intent(in) :: prt1 call msg_fatal (" 'Theta_star' is undefined as unary observable") dist = 0 end function obs_theta_star1 @ %def obs_theta_star1 @ [Obsolete] Meaningless: Polar angle in the rest frame of the 2nd argument. <>= real(default) function obs_theta_rf1 (prt1) result (dist) type(prt_t), intent(in) :: prt1 call msg_fatal (" 'Theta_RF' is undefined as unary observable") dist = 0 end function obs_theta_rf1 @ %def obs_theta_rf1 @ Meaningless: Distance on the $\eta$-$\phi$ cylinder. <>= real(default) function obs_dist1 (prt1) result (dist) type(prt_t), intent(in) :: prt1 call msg_fatal (" 'Dist' is undefined as unary observable") dist = 0 end function obs_dist1 @ %def obs_dist1 @ \subsubsection{Integer-valued binary observables} These observables are meaningless as binary functions. <>= integer function obs_pdg2 (prt1, prt2) result (pdg) type(prt_t), intent(in) :: prt1, prt2 call msg_fatal (" PDG_Code is undefined as binary observable") pdg = 0 end function obs_pdg2 integer function obs_helicity2 (prt1, prt2) result (h) type(prt_t), intent(in) :: prt1, prt2 call msg_fatal (" Helicity is undefined as binary observable") h = 0 end function obs_helicity2 integer function obs_n_col2 (prt1, prt2) result (n) type(prt_t), intent(in) :: prt1, prt2 call msg_fatal (" Ncol is undefined as binary observable") n = 0 end function obs_n_col2 integer function obs_n_acl2 (prt1, prt2) result (n) type(prt_t), intent(in) :: prt1, prt2 call msg_fatal (" Nacl is undefined as binary observable") n = 0 end function obs_n_acl2 @ %def obs_pdg2 @ %def obs_helicity2 @ %def obs_n_col2 @ %def obs_n_acl2 @ \subsubsection{Real-valued binary observables} The invariant mass squared, obtained from the separately stored value. <>= real(default) function obs_mass_squared2 (prt1, prt2) result (p2) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p2 = prt_get_msq (prt) end function obs_mass_squared2 @ %def obs_mass_squared2 @ The signed invariant mass, which is the signed square root of the previous observable. <>= real(default) function obs_signed_mass2 (prt1, prt2) result (m) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt real(default) :: msq call prt_init_combine (prt, prt1, prt2) msq = prt_get_msq (prt) m = sign (sqrt (abs (msq)), msq) end function obs_signed_mass2 @ %def obs_signed_mass2 @ The particle energy <>= real(default) function obs_energy2 (prt1, prt2) result (e) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) e = energy (prt_get_momentum (prt)) end function obs_energy2 @ %def obs_energy2 @ Particle momentum (components) <>= real(default) function obs_px2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = vector4_get_component (prt_get_momentum (prt), 1) end function obs_px2 real(default) function obs_py2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = vector4_get_component (prt_get_momentum (prt), 2) end function obs_py2 real(default) function obs_pz2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = vector4_get_component (prt_get_momentum (prt), 3) end function obs_pz2 real(default) function obs_p2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = space_part_norm (prt_get_momentum (prt)) end function obs_p2 real(default) function obs_pl2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = longitudinal_part (prt_get_momentum (prt)) end function obs_pl2 real(default) function obs_pt2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = transverse_part (prt_get_momentum (prt)) end function obs_pt2 @ %def obs_px2 obs_py2 obs_pz2 @ %def obs_p2 obs_pl2 obs_pt2 @ Enclosed angle and azimuthal distance (lab frame). <>= real(default) function obs_theta2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 p = enclosed_angle (prt_get_momentum (prt1), prt_get_momentum (prt2)) end function obs_theta2 real(default) function obs_phi2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = azimuthal_distance (prt_get_momentum (prt1), prt_get_momentum (prt2)) end function obs_phi2 @ %def obs_theta2 obs_phi2 @ Rapidity and pseudorapidity distance <>= real(default) function obs_rap2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 p = rapidity_distance & (prt_get_momentum (prt1), prt_get_momentum (prt2)) end function obs_rap2 real(default) function obs_eta2 (prt1, prt2) result (p) type(prt_t), intent(in) :: prt1, prt2 type(prt_t) :: prt call prt_init_combine (prt, prt1, prt2) p = pseudorapidity_distance & (prt_get_momentum (prt1), prt_get_momentum (prt2)) end function obs_eta2 @ %def obs_rap2 obs_eta2 @ [This doesn't work! The principle of no common particle for momentum combination prohibits us from combining a decay particle with the momentum of its parent.] Polar angle in the rest frame of the 2nd argument. <>= real(default) function obs_theta_rf2 (prt1, prt2) result (theta) type(prt_t), intent(in) :: prt1, prt2 theta = enclosed_angle_rest_frame & (prt_get_momentum (prt1), prt_get_momentum (prt2)) end function obs_theta_rf2 @ %def obs_theta_rf2 @ Polar angle of the first particle in the rest frame of the two particles combined. <>= real(default) function obs_theta_star2 (prt1, prt2) result (theta) type(prt_t), intent(in) :: prt1, prt2 theta = enclosed_angle_rest_frame & (prt_get_momentum (prt1), & prt_get_momentum (prt1) + prt_get_momentum (prt2)) end function obs_theta_star2 @ %def obs_theta_star2 @ Distance on the $\eta$-$\phi$ cylinder. <>= real(default) function obs_dist2 (prt1, prt2) result (dist) type(prt_t), intent(in) :: prt1, prt2 dist = eta_phi_distance & (prt_get_momentum (prt1), prt_get_momentum (prt2)) end function obs_dist2 @ %def obs_dist2 @ Durham kT measure. <>= real(default) function obs_ktmeasure (prt1, prt2) result (kt) type(prt_t), intent(in) :: prt1, prt2 real (default) :: q2, e1, e2 ! Normalized scale to one for now! (#67) q2 = 1 e1 = energy (prt_get_momentum (prt1)) e2 = energy (prt_get_momentum (prt2)) kt = (2/q2) * min(e1**2,e2**2) * & (1 - enclosed_angle_ct(prt_get_momentum (prt1), & prt_get_momentum (prt2))) end function obs_ktmeasure @ %def obs_ktmeasure @ Subeventary observables, e.g. the transverse mass $H_T$. <>= real(default) function obs_ht (sev) result (ht) type(subevt_t), intent(in) :: sev integer :: i, n type(prt_t) :: prt n = sev%get_length () ht = 0 do i = 1, n prt = sev%get_prt (i) ht = ht + & sqrt (obs_pt1(prt)**2 + obs_mass_squared1(prt)) end do end function obs_ht @ %def obs_ht \subsection{Process-specific variables} We allow the user to set a numeric process ID for each declared process. <>= public :: var_list_init_num_id <>= module subroutine var_list_init_num_id (var_list, proc_id, num_id) type(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: proc_id integer, intent(in), optional :: num_id end subroutine var_list_init_num_id <>= module subroutine var_list_init_num_id (var_list, proc_id, num_id) type(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: proc_id integer, intent(in), optional :: num_id call var_list%set_procvar_int (proc_id, var_str ("num_id"), num_id) end subroutine var_list_init_num_id @ %def var_list_init_num_id @ Integration results are stored in special variables. They are initialized by this subroutine. The values may or may not already known. Note: the values which are accessible are those that are unique for a process with multiple MCI records. The rest has been discarded. <>= public :: var_list_init_process_results <>= module subroutine var_list_init_process_results (var_list, proc_id, & n_calls, integral, error, accuracy, chi2, efficiency) type(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: proc_id integer, intent(in), optional :: n_calls real(default), intent(in), optional :: integral, error, accuracy real(default), intent(in), optional :: chi2, efficiency end subroutine var_list_init_process_results <>= module subroutine var_list_init_process_results (var_list, proc_id, & n_calls, integral, error, accuracy, chi2, efficiency) type(var_list_t), intent(inout) :: var_list type(string_t), intent(in) :: proc_id integer, intent(in), optional :: n_calls real(default), intent(in), optional :: integral, error, accuracy real(default), intent(in), optional :: chi2, efficiency call var_list%set_procvar_real (proc_id, var_str ("integral"), integral) call var_list%set_procvar_real (proc_id, var_str ("error"), error) end subroutine var_list_init_process_results @ %def var_list_init_process_results @ \subsection{Observables as Pseudo-Variables} Unary and binary observables are different. Most unary observables can be equally well evaluated for particle pairs. Binary observables cannot be evaluated for single particles. <>= public :: var_list_set_observables_unary public :: var_list_set_observables_binary public :: var_list_set_observables_sev <>= module subroutine var_list_set_observables_unary (var_list, prt1) type(var_list_t), intent(inout) :: var_list type(prt_t), intent(in), target :: prt1 end subroutine var_list_set_observables_unary module subroutine var_list_set_observables_binary (var_list, prt1, prt2) type(var_list_t), intent(inout) :: var_list type(prt_t), intent(in), target :: prt1 type(prt_t), intent(in), optional, target :: prt2 end subroutine var_list_set_observables_binary module subroutine var_list_set_observables_sev (var_list, pval) type(var_list_t), intent(inout) :: var_list type(subevt_t), intent(in), target:: pval end subroutine var_list_set_observables_sev <>= module subroutine var_list_set_observables_unary (var_list, prt1) type(var_list_t), intent(inout) :: var_list type(prt_t), intent(in), target :: prt1 call var_list%append_obs1_iptr (var_str ("PDG"), obs_pdg1, prt1) call var_list%append_obs1_iptr (var_str ("Hel"), obs_helicity1, prt1) call var_list%append_obs1_iptr (var_str ("Ncol"), obs_n_col1, prt1) call var_list%append_obs1_iptr (var_str ("Nacl"), obs_n_acl1, prt1) call var_list%append_obs1_rptr & (var_str ("M"), obs_signed_mass1, prt1) call var_list%append_obs1_rptr & (var_str ("M2"), obs_mass_squared1, prt1) call var_list%append_obs1_rptr (var_str ("E"), obs_energy1, prt1) call var_list%append_obs1_rptr (var_str ("Px"), obs_px1, prt1) call var_list%append_obs1_rptr (var_str ("Py"), obs_py1, prt1) call var_list%append_obs1_rptr (var_str ("Pz"), obs_pz1, prt1) call var_list%append_obs1_rptr (var_str ("P"), obs_p1, prt1) call var_list%append_obs1_rptr (var_str ("Pl"), obs_pl1, prt1) call var_list%append_obs1_rptr (var_str ("Pt"), obs_pt1, prt1) call var_list%append_obs1_rptr (var_str ("Theta"), obs_theta1, prt1) call var_list%append_obs1_rptr (var_str ("Phi"), obs_phi1, prt1) call var_list%append_obs1_rptr (var_str ("Rap"), obs_rap1, prt1) call var_list%append_obs1_rptr (var_str ("Eta"), obs_eta1, prt1) call var_list%append_obs1_rptr & (var_str ("Theta_star"), obs_theta_star1, prt1) call var_list%append_obs1_rptr (var_str ("Dist"), obs_dist1, prt1) call var_list%append_uobs_real (var_str ("_User_obs_real"), prt1) call var_list%append_uobs_int (var_str ("_User_obs_int"), prt1) end subroutine var_list_set_observables_unary module subroutine var_list_set_observables_binary (var_list, prt1, prt2) type(var_list_t), intent(inout) :: var_list type(prt_t), intent(in), target :: prt1 type(prt_t), intent(in), optional, target :: prt2 call var_list%append_obs2_iptr (var_str ("PDG"), obs_pdg2, prt1, prt2) call var_list%append_obs2_iptr (var_str ("Hel"), obs_helicity2, prt1, prt2) call var_list%append_obs2_iptr (var_str ("Ncol"), obs_n_col2, prt1, prt2) call var_list%append_obs2_iptr (var_str ("Nacl"), obs_n_acl2, prt1, prt2) call var_list%append_obs2_rptr (var_str ("M"), obs_signed_mass2, prt1, prt2) call var_list%append_obs2_rptr & (var_str ("M2"), obs_mass_squared2, prt1, prt2) call var_list%append_obs2_rptr (var_str ("E"), obs_energy2, prt1, prt2) call var_list%append_obs2_rptr (var_str ("Px"), obs_px2, prt1, prt2) call var_list%append_obs2_rptr (var_str ("Py"), obs_py2, prt1, prt2) call var_list%append_obs2_rptr (var_str ("Pz"), obs_pz2, prt1, prt2) call var_list%append_obs2_rptr (var_str ("P"), obs_p2, prt1, prt2) call var_list%append_obs2_rptr (var_str ("Pl"), obs_pl2, prt1, prt2) call var_list%append_obs2_rptr (var_str ("Pt"), obs_pt2, prt1, prt2) call var_list%append_obs2_rptr (var_str ("Theta"), obs_theta2, prt1, prt2) call var_list%append_obs2_rptr (var_str ("Phi"), obs_phi2, prt1, prt2) call var_list%append_obs2_rptr (var_str ("Rap"), obs_rap2, prt1, prt2) call var_list%append_obs2_rptr (var_str ("Eta"), obs_eta2, prt1, prt2) call var_list%append_obs2_rptr & (var_str ("Theta_star"), obs_theta_star2, prt1, prt2) call var_list%append_obs2_rptr (var_str ("Dist"), obs_dist2, prt1, prt2) call var_list%append_obs2_rptr (var_str ("kT"), obs_ktmeasure, prt1, prt2) call var_list%append_uobs_real (var_str ("_User_obs_real"), prt1, prt2) call var_list%append_uobs_int (var_str ("_User_obs_int"), prt1, prt2) end subroutine var_list_set_observables_binary module subroutine var_list_set_observables_sev (var_list, pval) type(var_list_t), intent(inout) :: var_list type(subevt_t), intent(in), target:: pval call var_list%append_obsev_rptr (var_str ("Ht"), obs_ht, pval) end subroutine var_list_set_observables_sev @ %def var_list_set_observables_unary var_list_set_observables_binary @ %def var_list_set_observables_nary \subsection{Checks} <>= public :: var_list_check_observable <>= module subroutine var_list_check_observable (var_list, name, type) class(var_list_t), intent(in), target :: var_list type(string_t), intent(in) :: name integer, intent(inout) :: type end subroutine var_list_check_observable <>= module subroutine var_list_check_observable (var_list, name, type) class(var_list_t), intent(in), target :: var_list type(string_t), intent(in) :: name integer, intent(inout) :: type if (string_is_observable_id (name)) then call msg_fatal ("Variable name '" // char (name) & // "' is reserved for an observable") type = V_NONE return end if end subroutine var_list_check_observable @ %def var_list_check_observable @ Check if a variable name is defined as an observable: <>= function string_is_observable_id (string) result (flag) logical :: flag type(string_t), intent(in) :: string select case (char (string)) case ("PDG", "Hel", "Ncol", "Nacl", & "M", "M2", "E", "Px", "Py", "Pz", "P", "Pl", "Pt", & "Theta", "Phi", "Rap", "Eta", "Theta_star", "Dist", "kT", & "Ht") flag = .true. case default flag = .false. end select end function string_is_observable_id @ %def string_is_observable_id @ Check for result and process variables. <>= public :: var_list_check_result_var <>= module subroutine var_list_check_result_var (var_list, name, type) class(var_list_t), intent(in), target :: var_list type(string_t), intent(in) :: name integer, intent(inout) :: type end subroutine var_list_check_result_var <>= module subroutine var_list_check_result_var (var_list, name, type) class(var_list_t), intent(in), target :: var_list type(string_t), intent(in) :: name integer, intent(inout) :: type if (string_is_integer_result_var (name)) type = V_INT if (.not. var_list%contains (name)) then if (string_is_result_var (name)) then call msg_fatal ("Result variable '" // char (name) // "' " & // "set without prior integration") type = V_NONE return else if (string_is_num_id (name)) then call msg_fatal ("Numeric process ID '" // char (name) // "' " & // "set without process declaration") type = V_NONE return end if end if end subroutine var_list_check_result_var @ %def var_list_check_result_var @ Check if a variable name is a result variable of integer type: <>= function string_is_integer_result_var (string) result (flag) logical :: flag type(string_t), intent(in) :: string type(string_t) :: buffer, name, separator buffer = string call split (buffer, name, "(", separator=separator) ! ")" if (separator == "(") then select case (char (name)) case ("num_id", "n_calls") flag = .true. case default flag = .false. end select else flag = .false. end if end function string_is_integer_result_var @ %def string_is_integer_result_var @ Check if a variable name is an integration-result variable: <>= function string_is_result_var (string) result (flag) logical :: flag type(string_t), intent(in) :: string type(string_t) :: buffer, name, separator buffer = string call split (buffer, name, "(", separator=separator) ! ")" if (separator == "(") then select case (char (name)) case ("integral", "error") flag = .true. case default flag = .false. end select else flag = .false. end if end function string_is_result_var @ %def string_is_result_var @ Check if a variable name is a numeric process ID: <>= function string_is_num_id (string) result (flag) logical :: flag type(string_t), intent(in) :: string type(string_t) :: buffer, name, separator buffer = string call split (buffer, name, "(", separator=separator) ! ")" if (separator == "(") then select case (char (name)) case ("num_id") flag = .true. case default flag = .false. end select else flag = .false. end if end function string_is_num_id @ %def string_is_num_id @ Index: trunk/src/Makefile.am =================================================================== --- trunk/src/Makefile.am (revision 8815) +++ trunk/src/Makefile.am (revision 8816) @@ -1,355 +1,356 @@ ## Makefile.am -- Makefile for WHIZARD ## ## Process this file with automake to produce Makefile.in # # Copyright (C) 1999-2022 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## ## Subdirectories to configure ## directories in one line do not depend on each other SUBDIRS = \ noweb-frame \ basics \ hepmc lcio lhapdf lhapdf5 looptools xdr \ expr_base utilities \ system \ combinatorics pdf_builtin testing \ hoppet \ muli parsing physics qed_pdf \ fastjet types qft threshold \ models particles matrix_elements variables \ events prebuilt rng \ beams tauola \ me_methods pythia8 shower \ blha model_features \ gosam openloops \ recola phase_space \ fks vegas mci \ process_integration \ matching \ transforms \ whizard-core \ api \ main if MPOST_AVAILABLE SUBDIRS += gamelan feynmf endif ######################################################################## ## Build ## (1) the toplevel WHIZARD library, which wraps various libraries ## built in the subdirectories ## (2) the WHIZARD test library that is linked to the main executable ## as the provider of internal unit tests ## (3) the wrapper O'Mega library, which contains omegalib and ## the W/O interface modules for the various models lib_LTLIBRARIES = libwhizard.la libomega.la libwhizard_la_SOURCES = libwhizard_la_LDFLAGS = $(LIBRARY_VERSION) ## Collect the various partial libraries libwhizard_la_LIBADD = \ api/libapi.la \ threshold/libthreshold.la \ whizard-core/libwhizard_core.la \ transforms/libtransforms.la \ ../vamp/src/libvamp.la \ ../circe1/src/libcirce1.la \ ../circe2/src/libcirce2.la \ shower/libshower.la \ tauola/libtauola_interface.la \ muli/libmuli.la \ pdf_builtin/libpdf_builtin.la \ model_features/libmodel_features.la \ variables/libvariables.la \ process_integration/libprocess_integration.la \ matching/libmatching.la \ fks/libfks.la \ gosam/libgosam.la \ openloops/liboloops.la \ recola/libwo_recola.la \ blha/libblha.la \ vegas/libvegas.la \ mci/libmci.la \ phase_space/libphase_space.la \ xdr/libWOStdHep.la \ events/libevents.la \ beams/libbeams.la \ particles/libparticles.la \ me_methods/libme_methods.la \ matrix_elements/libmatrix_elements.la \ types/libtypes.la \ qft/libqft.la \ physics/libphysics.la \ qed_pdf/libqed_pdf.la \ expr_base/libexpr_base.la \ rng/librng.la \ parsing/libparsing.la \ combinatorics/libcombinatorics.la \ system/libsystem.la \ testing/libtesting.la \ utilities/libutilities.la \ basics/libbasics.la if HEPMC_AVAILABLE libwhizard_la_LIBADD += hepmc/libHepMCWrap.la else libwhizard_la_LIBADD += hepmc/libHepMCWrap_dummy.la endif if LCIO_AVAILABLE libwhizard_la_LIBADD += lcio/libLCIOWrap.la else libwhizard_la_LIBADD += lcio/libLCIOWrap_dummy.la endif ## If (parts of) LHAPDF is not available, link in a dummy as replacements if LHAPDF5_AVAILABLE libwhizard_la_LIBADD += $(LDFLAGS_LHAPDF) if LHAPDF5_HAS_PHOTON_DUMMY libwhizard_la_LIBADD += lhapdf5/libLHAPDF5_dummy.la endif else if !LHAPDF6_AVAILABLE libwhizard_la_LIBADD += lhapdf5/libLHAPDF5_dummy.la endif endif if LHAPDF6_AVAILABLE libwhizard_la_LIBADD += $(LHAPDF_LIBS) lhapdf/libLHAPDFWrap.la else libwhizard_la_LIBADD += lhapdf/libLHAPDFWrap_dummy.la endif if HOPPET_AVAILABLE libwhizard_la_LIBADD += $(LDFLAGS_HOPPET) hoppet/libhoppet.la else libwhizard_la_LIBADD += hoppet/libhoppet_dummy.la endif if FASTJET_AVAILABLE libwhizard_la_LIBADD += $(FASTJET_LIBS) fastjet/libFastjetWrap.la else libwhizard_la_LIBADD += fastjet/libFastjetWrap_dummy.la endif if LOOPTOOLS_AVAILABLE libwhizard_la_LIBADD += $(LDFLAGS_LOOPTOOLS) looptools/liblooptools.la else libwhizard_la_LIBADD += looptools/liblooptools_dummy.la endif libwhizard_la_LIBADD += $(PYTHIA8_LIBS) pythia8/libwo_pythia8.la if IS_IFORT_DARWIN libwhizard_la_LIBADD += $(FCLIBS) endif ## ------------------------------------------------------------------- ## WHIZARD unit-test library check_LTLIBRARIES = libwhizard_ut.la libwhizard_ut_la_SOURCES = libwhizard_ut_la_LIBADD = \ main/libwhizard_main_ut.la \ api/libapi_ut.la \ threshold/libthreshold_ut.la \ whizard-core/libwhizard_core_ut.la \ transforms/libtransforms_ut.la \ matching/libmatching_ut.la \ fks/libfks_ut.la \ shower/libshower_ut.la \ process_integration/libprocess_integration_ut.la \ recola/libwo_recola_ut.la \ blha/libblha_ut.la \ model_features/libmodel_features_ut.la \ vegas/libvegas_ut.la mci/libmci_ut.la \ phase_space/libphase_space_ut.la \ pythia8/libwo_pythia8_ut.la \ events/libevents_ut.la \ beams/libbeams_ut.la \ particles/libparticles_ut.la \ me_methods/libme_methods_ut.la \ matrix_elements/libmatrix_elements_ut.la \ types/libtypes_ut.la \ qft/libqft_ut.la \ + qed_pdf/libqed_pdf_ut.la \ physics/libphysics_ut.la \ rng/librng_ut.la \ parsing/libparsing_ut.la \ combinatorics/libcombinatorics_ut.la \ system/libsystem_ut.la \ utilities/libutilities_ut.la ## ------------------------------------------------------------------- ## WHIZARD C API test library check_LTLIBRARIES += libwhizard_ut_c.la libwhizard_ut_c_la_SOURCES = libwhizard_ut_c_la_LIBADD = \ api/libapi_ut_c.la ## ------------------------------------------------------------------- ## WHIZARD C++ API test library check_LTLIBRARIES += libwhizard_ut_cc.la libwhizard_ut_cc_la_SOURCES = libwhizard_ut_cc_la_LIBADD = \ api/libapi_ut_cc.la ## ------------------------------------------------------------------- ## O'Mega main library libomega_la_SOURCES = libomega_la_LIBADD = \ ../omega/src/libomega_core.la \ models/libmodels.la if RECOLA_AVAILABLE libwhizard_la_LIBADD += $(LDFLAGS_RECOLA) libwhizard_ut_la_LIBADD += $(LDFLAGS_RECOLA) endif ######################################################################## ## Build a standalone program bin_PROGRAMS = whizard whizard_SOURCES = ## A dummy source tells libtool that the F90 compiler is used for linking ## Without dummy, libtool uses the C linker (default: ld) nodist_EXTRA_whizard_SOURCES = dummy.f90 whizard_LDADD = main/libwhizard_main.la whizard_LDADD += ./libwhizard.la whizard_LDADD += prebuilt/libwhizard_prebuilt.la whizard_LDADD += $(CXXLIBS) whizard_LDADD += $(RPC_CFLAGS) whizard_LDADD += $(LDFLAGS_LHAPDF) whizard_LDADD += $(LDFLAGS_HEPMC) whizard_LDADD += $(LDFLAGS_LCIO) whizard_LDADD += $(LDFLAGS_HOPPET) whizard_LDADD += $(FASTJET_LIBS) whizard_LDADD += $(LDFLAGS_LOOPTOOLS) ## ------------------------------------------------------------------- ## Build a standalone program for running the Fortran unit tests check_PROGRAMS = whizard_ut whizard_ut_SOURCES = ## A dummy source tells libtool that the F90 compiler is used for linking ## Without dummy, libtool uses the C linker (default: ld) nodist_EXTRA_whizard_ut_SOURCES = dummy.f90 whizard_ut_LDADD = ./libwhizard_ut.la whizard_ut_LDADD += ./libwhizard.la whizard_ut_LDADD += prebuilt/libwhizard_prebuilt.la whizard_ut_LDADD += $(CXXLIBS) whizard_ut_LDADD += $(RPC_CFLAGS) whizard_ut_LDADD += $(LDFLAGS_LHAPDF) whizard_ut_LDADD += $(LDFLAGS_HEPMC) whizard_ut_LDADD += $(LDFLAGS_LCIO) whizard_ut_LDADD += $(LDFLAGS_HOPPET) whizard_ut_LDADD += $(FASTJET_LIBS) whizard_ut_LDADD += $(LDFLAGS_LOOPTOOLS) ## ------------------------------------------------------------------- ## Build a standalone program for running the C interface test check_PROGRAMS += whizard_ut_c whizard_ut_c_SOURCES = whizard_ut_c_LDADD = ./libwhizard_ut_c.la whizard_ut_c_LDADD += ./libwhizard.la whizard_ut_c_LDADD += prebuilt/libwhizard_prebuilt.la whizard_ut_c_LDADD += $(CXXLIBS) whizard_ut_c_LDADD += $(RPC_CFLAGS) whizard_ut_c_LDADD += $(LDFLAGS_LHAPDF) whizard_ut_c_LDADD += $(LDFLAGS_HEPMC) whizard_ut_c_LDADD += $(LDFLAGS_LCIO) whizard_ut_c_LDADD += $(LDFLAGS_HOPPET) whizard_ut_c_LDADD += $(FASTJET_LIBS) whizard_ut_c_LDADD += $(LDFLAGS_LOOPTOOLS) ## ------------------------------------------------------------------- ## Build a standalone program for running the C++ interface test check_PROGRAMS += whizard_ut_cc ## A dummy source tells libtool that the C++ compiler is used for linking ## Without dummy, libtool uses the C linker (default: ld) whizard_ut_cc_SOURCES = nodist_EXTRA_whizard_ut_cc_SOURCES = dummy_cc.cc whizard_ut_cc_LDADD = ./libwhizard_ut_cc.la whizard_ut_cc_LDADD += ./libwhizard.la whizard_ut_cc_LDADD += prebuilt/libwhizard_prebuilt.la whizard_ut_cc_LDADD += $(CXXLIBS) whizard_ut_cc_LDADD += $(RPC_CFLAGS) whizard_ut_cc_LDADD += $(LDFLAGS_LHAPDF) whizard_ut_cc_LDADD += $(LDFLAGS_HEPMC) whizard_ut_cc_LDADD += $(LDFLAGS_LCIO) whizard_ut_cc_LDADD += $(LDFLAGS_HOPPET) whizard_ut_cc_LDADD += $(FASTJET_LIBS) whizard_ut_cc_LDADD += $(LDFLAGS_LOOPTOOLS) ######################################################################## ## Default Fortran compiler options AM_FCFLAGS = ## Profiling if FC_USE_PROFILING AM_FCFLAGS += $(FCFLAGS_PROFILING) endif ## OpenMP if FC_USE_OPENMP AM_FCFLAGS += $(FCFLAGS_OPENMP) endif ######################################################################## ## Non-standard cleanup tasks ## Remove backup files maintainer-clean-local: -rm -f *~ ## Remove Module lists only after final subdir cleanup distclean-local: for d in $(SUBDIRS); do \ rm -f $$d/Modules; \ done Index: trunk/src/utilities/utilities.nw =================================================================== --- trunk/src/utilities/utilities.nw (revision 8815) +++ trunk/src/utilities/utilities.nw (revision 8816) @@ -1,3699 +1,4744 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; noweb-code-mode: f90-mode -*- % WHIZARD code as NOWEB source: Utilities \chapter{Utilities} \includemodulegraph{utilities} These modules are intended as part of WHIZARD, but in fact they are generic and could be useful for any purpose. The modules depend only on modules from the [[basics]] set. \begin{description} \item[file\_utils] Procedures that deal with external files, if not covered by Fortran built-ins. \item[file\_registries] Manage files that are accessed by their name. \item[string\_utils] Some string-handling utilities. Includes conversion to C string. \item[format\_utils] Utilities for pretty-printing. \item[format\_defs] Predefined format strings. \item[numeric\_utils] Utilities for comparing numerical values. \item[data\_utils] Utitilies for data structures, i.e. a fixed size queue, polymorphic binary tree and dynamic array list. \end{description} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{File Utilities} This module provides miscellaneous tools associated with named external files. Currently only: \begin{itemize} \item Delete a named file \end{itemize} <<[[file_utils.f90]]>>= <> module file_utils <> <> interface <> end interface end module file_utils @ %def file_utils <<[[file_utils_sub.f90]]>>= <> submodule (file_utils) file_utils_s use io_units implicit none contains <> end submodule file_utils_s @ %def file_utils_s @ \subsection{Deleting a file} Fortran does not contain a command for deleting a file. Here, we provide a subroutine that deletes a file if it exists. We do not handle the subtleties, so we assume that it is writable if it exists. <>= public :: delete_file <>= module subroutine delete_file (name) character(*), intent(in) :: name end subroutine delete_file <>= module subroutine delete_file (name) character(*), intent(in) :: name logical :: exist integer :: u inquire (file = name, exist = exist) if (exist) then u = free_unit () open (unit = u, file = name) close (u, status = "delete") end if end subroutine delete_file @ %def delete_file @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{File Registries} This module provides a file-registry facility. We can open and close files multiple times without inadvertedly accessing a single file by two different I/O unit numbers. Opening a file the first time enters it into the registry. Opening again just returns the associated I/O unit. The registry maintains a reference count, so closing a file does not actually complete until the last reference is released. File access will always be sequential, however. The file can't be opened at different positions simultaneously. <<[[file_registries.f90]]>>= <> module file_registries <> <> <> <> interface <> end interface end module file_registries @ %def file_registries @ <<[[file_registries_sub.f90]]>>= <> submodule (file_registries) file_registries_s use io_units implicit none contains <> end submodule file_registries_s @ \subsection{File handle} This object holds a filename (fully qualified), the associated unit, and a reference count. The idea is that the object should be deleted when the reference count drops to zero. <>= type :: file_handle_t type(string_t) :: file integer :: unit = 0 integer :: refcount = 0 contains <> end type file_handle_t @ %def file_handle_t @ Debugging output: <>= procedure :: write => file_handle_write <>= module subroutine file_handle_write (handle, u, show_unit) class(file_handle_t), intent(in) :: handle integer, intent(in) :: u logical, intent(in), optional :: show_unit end subroutine file_handle_write <>= module subroutine file_handle_write (handle, u, show_unit) class(file_handle_t), intent(in) :: handle integer, intent(in) :: u logical, intent(in), optional :: show_unit logical :: show_u show_u = .false.; if (present (show_unit)) show_u = show_unit if (show_u) then write (u, "(3x,A,1x,I0,1x,'(',I0,')')") & char (handle%file), handle%unit, handle%refcount else write (u, "(3x,A,1x,'(',I0,')')") & char (handle%file), handle%refcount end if end subroutine file_handle_write @ %def file_handle_write @ Initialize with a file name, don't open the file yet: <>= procedure :: init => file_handle_init <>= module subroutine file_handle_init (handle, file) class(file_handle_t), intent(out) :: handle type(string_t), intent(in) :: file end subroutine file_handle_init <>= module subroutine file_handle_init (handle, file) class(file_handle_t), intent(out) :: handle type(string_t), intent(in) :: file handle%file = file end subroutine file_handle_init @ %def file_handle_init @ We check the [[refcount]] before actually opening the file. <>= procedure :: open => file_handle_open <>= module subroutine file_handle_open (handle) class(file_handle_t), intent(inout) :: handle end subroutine file_handle_open <>= module subroutine file_handle_open (handle) class(file_handle_t), intent(inout) :: handle if (handle%refcount == 0) then handle%unit = free_unit () open (unit = handle%unit, file = char (handle%file), action = "read", & status = "old") end if handle%refcount = handle%refcount + 1 end subroutine file_handle_open @ %def file_handle_open @ Analogously, close if the refcount drops to zero. The caller may then delete the object. <>= procedure :: close => file_handle_close <>= module subroutine file_handle_close (handle) class(file_handle_t), intent(inout) :: handle end subroutine file_handle_close <>= module subroutine file_handle_close (handle) class(file_handle_t), intent(inout) :: handle handle%refcount = handle%refcount - 1 if (handle%refcount == 0) then close (handle%unit) handle%unit = 0 end if end subroutine file_handle_close @ %def file_handle_close @ The I/O unit will be nonzero when the file is open. <>= procedure :: is_open => file_handle_is_open <>= module function file_handle_is_open (handle) result (flag) class(file_handle_t), intent(in) :: handle logical :: flag end function file_handle_is_open <>= module function file_handle_is_open (handle) result (flag) class(file_handle_t), intent(in) :: handle logical :: flag flag = handle%unit /= 0 end function file_handle_is_open @ %def file_handle_is_open @ Return the filename, so we can identify the entry. <>= procedure :: get_file => file_handle_get_file <>= module function file_handle_get_file (handle) result (file) class(file_handle_t), intent(in) :: handle type(string_t) :: file end function file_handle_get_file <>= module function file_handle_get_file (handle) result (file) class(file_handle_t), intent(in) :: handle type(string_t) :: file file = handle%file end function file_handle_get_file @ %def file_handle_get_file @ For debugging, return the I/O unit number. <>= procedure :: get_unit => file_handle_get_unit <>= module function file_handle_get_unit (handle) result (unit) class(file_handle_t), intent(in) :: handle integer :: unit end function file_handle_get_unit <>= module function file_handle_get_unit (handle) result (unit) class(file_handle_t), intent(in) :: handle integer :: unit unit = handle%unit end function file_handle_get_unit @ %def file_handle_get_unit @ \subsection{File handles registry} This is implemented as a doubly-linked list. The list exists only once in the program, as a private module variable. Extend the handle type to become a list entry: <>= type, extends (file_handle_t) :: file_entry_t type(file_entry_t), pointer :: prev => null () type(file_entry_t), pointer :: next => null () end type file_entry_t @ %def file_entry_t @ The actual registry. We need only the pointer to the first entry. <>= public :: file_registry_t <>= type :: file_registry_t type(file_entry_t), pointer :: first => null () contains <> end type file_registry_t @ %def file_registry_t @ Debugging output. <>= procedure :: write => file_registry_write <>= module subroutine file_registry_write (registry, unit, show_unit) class(file_registry_t), intent(in) :: registry integer, intent(in), optional :: unit logical, intent(in), optional :: show_unit end subroutine file_registry_write <>= module subroutine file_registry_write (registry, unit, show_unit) class(file_registry_t), intent(in) :: registry integer, intent(in), optional :: unit logical, intent(in), optional :: show_unit type(file_entry_t), pointer :: entry integer :: u u = given_output_unit (unit) if (associated (registry%first)) then write (u, "(1x,A)") "File registry:" entry => registry%first do while (associated (entry)) call entry%write (u, show_unit) entry => entry%next end do else write (u, "(1x,A)") "File registry: [empty]" end if end subroutine file_registry_write @ %def file_registry_write @ Open a file: find the appropriate entry. Create a new entry and add to the list if necessary. The list is extended at the beginning. Return the I/O unit number for the records. <>= procedure :: open => file_registry_open <>= module subroutine file_registry_open (registry, file, unit) class(file_registry_t), intent(inout) :: registry type(string_t), intent(in) :: file integer, intent(out), optional :: unit end subroutine file_registry_open <>= module subroutine file_registry_open (registry, file, unit) class(file_registry_t), intent(inout) :: registry type(string_t), intent(in) :: file integer, intent(out), optional :: unit type(file_entry_t), pointer :: entry entry => registry%first FIND_ENTRY: do while (associated (entry)) if (entry%get_file () == file) exit FIND_ENTRY entry => entry%next end do FIND_ENTRY if (.not. associated (entry)) then allocate (entry) call entry%init (file) if (associated (registry%first)) then registry%first%prev => entry entry%next => registry%first end if registry%first => entry end if call entry%open () if (present (unit)) unit = entry%get_unit () end subroutine file_registry_open @ %def file_registry_open @ Close a file: find the appropriate entry. Delete the entry if there is no file connected to it anymore. <>= procedure :: close => file_registry_close <>= module subroutine file_registry_close (registry, file) class(file_registry_t), intent(inout) :: registry type(string_t), intent(in) :: file end subroutine file_registry_close <>= module subroutine file_registry_close (registry, file) class(file_registry_t), intent(inout) :: registry type(string_t), intent(in) :: file type(file_entry_t), pointer :: entry entry => registry%first FIND_ENTRY: do while (associated (entry)) if (entry%get_file () == file) exit FIND_ENTRY entry => entry%next end do FIND_ENTRY if (associated (entry)) then call entry%close () if (.not. entry%is_open ()) then if (associated (entry%prev)) then entry%prev%next => entry%next else registry%first => entry%next end if if (associated (entry%next)) then entry%next%prev => entry%prev end if deallocate (entry) end if end if end subroutine file_registry_close @ %def file_registry_close @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{String Utilities} This module provides tools associated with strings (built-in and variable). Currently: \begin{itemize} \item Upper and lower case for strings \item Convert to null-terminated C string \end{itemize} <<[[string_utils.f90]]>>= <> module string_utils use, intrinsic :: iso_c_binding <> <> <> <> <> interface <> end interface end module string_utils @ %def string_utils @ <<[[string_utils_sub.f90]]>>= <> submodule (string_utils) string_utils_s implicit none contains <> end submodule string_utils_s @ %def string_utils_s @ \subsection{Upper and Lower Case} These are, unfortunately, not part of Fortran. <>= public :: upper_case public :: lower_case <>= interface upper_case module procedure upper_case_char, upper_case_string end interface interface lower_case module procedure lower_case_char, lower_case_string end interface <>= module function upper_case_char (string) result (new_string) character(*), intent(in) :: string character(len(string)) :: new_string end function upper_case_char module function lower_case_char (string) result (new_string) character(*), intent(in) :: string character(len(string)) :: new_string end function lower_case_char module function upper_case_string (string) result (new_string) type(string_t), intent(in) :: string type(string_t) :: new_string end function upper_case_string module function lower_case_string (string) result (new_string) type(string_t), intent(in) :: string type(string_t) :: new_string end function lower_case_string <>= module function upper_case_char (string) result (new_string) character(*), intent(in) :: string character(len(string)) :: new_string integer :: pos, code integer, parameter :: offset = ichar('A')-ichar('a') do pos = 1, len (string) code = ichar (string(pos:pos)) select case (code) case (ichar('a'):ichar('z')) new_string(pos:pos) = char (code + offset) case default new_string(pos:pos) = string(pos:pos) end select end do end function upper_case_char module function lower_case_char (string) result (new_string) character(*), intent(in) :: string character(len(string)) :: new_string integer :: pos, code integer, parameter :: offset = ichar('a')-ichar('A') do pos = 1, len (string) code = ichar (string(pos:pos)) select case (code) case (ichar('A'):ichar('Z')) new_string(pos:pos) = char (code + offset) case default new_string(pos:pos) = string(pos:pos) end select end do end function lower_case_char module function upper_case_string (string) result (new_string) type(string_t), intent(in) :: string type(string_t) :: new_string new_string = upper_case_char (char (string)) end function upper_case_string module function lower_case_string (string) result (new_string) type(string_t), intent(in) :: string type(string_t) :: new_string new_string = lower_case_char (char (string)) end function lower_case_string @ %def upper_case lower_case @ \subsection{C-Fortran String Conversion} Convert a FORTRAN string to a null-terminated C string. <>= public :: string_f2c <>= interface string_f2c module procedure string_f2c_char, string_f2c_var_str end interface string_f2c <>= pure module function string_f2c_char (i) result (o) character(*), intent(in) :: i character(kind=c_char, len=len (i) + 1) :: o end function string_f2c_char pure module function string_f2c_var_str (i) result (o) type(string_t), intent(in) :: i character(kind=c_char, len=len (i) + 1) :: o end function string_f2c_var_str <>= pure module function string_f2c_char (i) result (o) character(*), intent(in) :: i character(kind=c_char, len=len (i) + 1) :: o o = i // c_null_char end function string_f2c_char pure module function string_f2c_var_str (i) result (o) type(string_t), intent(in) :: i character(kind=c_char, len=len (i) + 1) :: o o = char (i) // c_null_char end function string_f2c_var_str @ %def string_f2c @ The same task done by a subroutine, analogous to the C [[strcpy]] function. We append a null char and copy the characters to the output string, given by a character array -- which is equal to a [[c_char]] character string by the rule of sequence association. Note: Just like with the [[strcpy]] function, there is no bounds check. <>= public :: strcpy_f2c <>= module subroutine strcpy_f2c (fstring, cstring) character(*), intent(in) :: fstring character(c_char), dimension(*), intent(inout) :: cstring end subroutine strcpy_f2c <>= module subroutine strcpy_f2c (fstring, cstring) character(*), intent(in) :: fstring character(c_char), dimension(*), intent(inout) :: cstring integer :: i do i = 1, len (fstring) cstring(i) = fstring(i:i) end do cstring(len(fstring)+1) = c_null_char end subroutine strcpy_f2c @ %def strcpy_f2c @ Convert a null-terminated C string to a Fortran string. The C-string argument is sequence-associated to a one-dimensional array of C characters, where we do not know the dimension. To convert this to a [[string_t]] object, we need to assign it or to wrap it by another [[var_str]] conversion. <>= public :: string_c2f <>= module function string_c2f (cstring) result (fstring) character(c_char), dimension(*), intent(in) :: cstring character(:), allocatable :: fstring end function string_c2f <>= module function string_c2f (cstring) result (fstring) character(c_char), dimension(*), intent(in) :: cstring character(:), allocatable :: fstring integer :: i, n n = 0 do while (cstring(n+1) /= c_null_char) n = n + 1 end do allocate (character(n) :: fstring) do i = 1, n fstring(i:i) = cstring(i) end do end function string_c2f @ %def string_c2f @ \subsection{Number Conversion} Create a string from a number. We use fixed format for the reals and variable format for integers. <>= public :: str <>= interface str module procedure str_log, str_logs, str_int, str_ints, & str_real, str_reals, str_complex, str_complexs end interface <>= module function str_log (l) result (s) logical, intent(in) :: l type(string_t) :: s end function str_log module function str_logs (x) result (s) logical, dimension(:), intent(in) :: x type(string_t) :: s end function str_logs module function str_int (i) result (s) integer, intent(in) :: i type(string_t) :: s end function str_int module function str_ints (x) result (s) integer, dimension(:), intent(in) :: x type(string_t) :: s end function str_ints module function str_real (x) result (s) real(default), intent(in) :: x type(string_t) :: s end function str_real module function str_reals (x) result (s) real(default), dimension(:), intent(in) :: x type(string_t) :: s end function str_reals module function str_complex (x) result (s) complex(default), intent(in) :: x type(string_t) :: s end function str_complex module function str_complexs (x) result (s) complex(default), dimension(:), intent(in) :: x type(string_t) :: s end function str_complexs <>= module function str_log (l) result (s) logical, intent(in) :: l type(string_t) :: s if (l) then s = "True" else s = "False" end if end function str_log module function str_logs (x) result (s) logical, dimension(:), intent(in) :: x <> end function str_logs module function str_int (i) result (s) integer, intent(in) :: i type(string_t) :: s character(32) :: buffer write (buffer, "(I0)") i s = var_str (trim (adjustl (buffer))) end function str_int module function str_ints (x) result (s) integer, dimension(:), intent(in) :: x <> end function str_ints module function str_real (x) result (s) real(default), intent(in) :: x type(string_t) :: s character(32) :: buffer write (buffer, "(ES17.10)") x s = var_str (trim (adjustl (buffer))) end function str_real module function str_reals (x) result (s) real(default), dimension(:), intent(in) :: x <> end function str_reals module function str_complex (x) result (s) complex(default), intent(in) :: x type(string_t) :: s s = str_real (real (x)) // " + i " // str_real (aimag (x)) end function str_complex module function str_complexs (x) result (s) complex(default), dimension(:), intent(in) :: x <> end function str_complexs @ %def str <>= type(string_t) :: s integer :: i s = '[' do i = 1, size(x) - 1 s = s // str(x(i)) // ', ' end do s = s // str(x(size(x))) // ']' @ @ Auxiliary: Read real, integer, string value. <>= public :: read_rval public :: read_ival <>= module function read_rval (s) result (rval) real(default) :: rval type(string_t), intent(in) :: s end function read_rval module function read_ival (s) result (ival) integer :: ival type(string_t), intent(in) :: s end function read_ival <>= module function read_rval (s) result (rval) real(default) :: rval type(string_t), intent(in) :: s character(80) :: buffer buffer = s read (buffer, *) rval end function read_rval module function read_ival (s) result (ival) integer :: ival type(string_t), intent(in) :: s character(80) :: buffer buffer = s read (buffer, *) ival end function read_ival @ %def read_rval read_ival @ \subsection{String splitting} <>= public :: string_contains_word <>= pure module function string_contains_word & (str, word, include_identical) result (val) logical :: val type(string_t), intent(in) :: str, word logical, intent(in), optional :: include_identical end function string_contains_word <>= pure module function string_contains_word & (str, word, include_identical) result (val) logical :: val type(string_t), intent(in) :: str, word type(string_t) :: str_tmp, str_out logical, intent(in), optional :: include_identical logical :: yorn str_tmp = str val = .false. yorn = .false.; if (present (include_identical)) yorn = include_identical if (yorn) val = str == word call split (str_tmp, str_out, word) val = val .or. (str_out /= "") end function string_contains_word @ %def string_contains_word @ Create an array of strings using a separator. <>= public :: split_string <>= pure module subroutine split_string (str, separator, str_array) type(string_t), dimension(:), allocatable, intent(out) :: str_array type(string_t), intent(in) :: str, separator end subroutine split_string <>= pure module subroutine split_string (str, separator, str_array) type(string_t), dimension(:), allocatable, intent(out) :: str_array type(string_t), intent(in) :: str, separator type(string_t) :: str_tmp, str_out integer :: n_str n_str = 0; str_tmp = str do while (string_contains_word (str_tmp, separator)) n_str = n_str + 1 call split (str_tmp, str_out, separator) end do allocate (str_array (n_str)) n_str = 1; str_tmp = str do while (string_contains_word (str_tmp, separator)) call split (str_tmp, str_array (n_str), separator) n_str = n_str + 1 end do end subroutine split_string @ %def split_string @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Format Utilities} This module provides miscellaneous tools associated with formatting and pretty-printing. \begin{itemize} \item Horizontal separator lines in output \item Indenting an output line \item Formatting a number for \TeX\ output. \item Formatting a number for MetaPost output. \item Alternate numeric formats. \end{itemize} <<[[format_utils.f90]]>>= <> module format_utils <> <> <> <> interface <> end interface end module format_utils @ %def format_utils @ <<[[format_utils_sub.f90]]>>= <> submodule (format_utils) format_utils_s use string_utils, only: lower_case use io_units, only: given_output_unit implicit none contains <> end submodule format_utils_s @ %def format_utils_s @ \subsection{Line Output} Write a separator line. <>= public :: write_separator <>= module subroutine write_separator (u, mode) integer, intent(in) :: u integer, intent(in), optional :: mode end subroutine write_separator <>= module subroutine write_separator (u, mode) integer, intent(in) :: u integer, intent(in), optional :: mode integer :: m m = 1; if (present (mode)) m = mode select case (m) case default write (u, "(A)") repeat ("-", 72) case (1) write (u, "(A)") repeat ("-", 72) case (2) write (u, "(A)") repeat ("=", 72) end select end subroutine write_separator @ %def write_separator @ Indent the line with given number of blanks. <>= public :: write_indent <>= module subroutine write_indent (unit, indent) integer, intent(in) :: unit integer, intent(in), optional :: indent end subroutine write_indent <>= module subroutine write_indent (unit, indent) integer, intent(in) :: unit integer, intent(in), optional :: indent if (present (indent)) then write (unit, "(1x,A)", advance="no") repeat (" ", indent) end if end subroutine write_indent @ %def write_indent @ \subsection{Array Output} Write an array of integers. <>= public :: write_integer_array <>= module subroutine write_integer_array (array, unit, n_max, no_skip) integer, intent(in), dimension(:) :: array integer, intent(in), optional :: unit integer, intent(in), optional :: n_max logical, intent(in), optional :: no_skip end subroutine write_integer_array <>= module subroutine write_integer_array (array, unit, n_max, no_skip) integer, intent(in), dimension(:) :: array integer, intent(in), optional :: unit integer, intent(in), optional :: n_max logical, intent(in), optional :: no_skip integer :: u, i, n logical :: yorn u = given_output_unit (unit) yorn = .false.; if (present (no_skip)) yorn = no_skip if (present (n_max)) then n = n_max else n = size (array) end if do i = 1, n if (i < n .or. yorn) then write (u, "(I0, A)", advance = "no") array(i), ", " else write (u, "(I0)") array(i) end if end do end subroutine write_integer_array @ %def write_integer_array @ \subsection{\TeX-compatible Output} Quote underscore characters for use in \TeX\ output. <>= public :: quote_underscore <>= module function quote_underscore (string) result (quoted) type(string_t) :: quoted type(string_t), intent(in) :: string end function quote_underscore <>= module function quote_underscore (string) result (quoted) type(string_t) :: quoted type(string_t), intent(in) :: string type(string_t) :: part type(string_t) :: buffer buffer = string quoted = "" do call split (part, buffer, "_") quoted = quoted // part if (buffer == "") exit quoted = quoted // "\_" end do end function quote_underscore @ %def quote_underscore @ Format a number with $n$ significant digits for use in \TeX\ documents. <>= public :: tex_format <>= module function tex_format (rval, n_digits) result (string) type(string_t) :: string real(default), intent(in) :: rval integer, intent(in) :: n_digits end function tex_format <>= module function tex_format (rval, n_digits) result (string) type(string_t) :: string real(default), intent(in) :: rval integer, intent(in) :: n_digits integer :: e, n, w, d real(default) :: absval real(default) :: mantissa character :: sign character(20) :: format character(80) :: cstr n = min (abs (n_digits), 16) if (rval == 0) then string = "0" else absval = abs (rval) e = int (log10 (absval)) if (rval < 0) then sign = "-" else sign = "" end if select case (e) case (:-3) d = max (n - 1, 0) w = max (d + 2, 2) write (format, "('(F',I0,'.',I0,',A,I0,A)')") w, d mantissa = absval * 10._default ** (1 - e) write (cstr, fmt=format) mantissa, "\times 10^{", e - 1, "}" case (-2:0) d = max (n - e, 1 - e) w = max (d + e + 2, d + 2) write (format, "('(F',I0,'.',I0,')')") w, d write (cstr, fmt=format) absval case (1:2) d = max (n - e - 1, -e, 0) w = max (d + e + 2, d + 2, e + 2) write (format, "('(F',I0,'.',I0,')')") w, d write (cstr, fmt=format) absval case default d = max (n - 1, 0) w = max (d + 2, 2) write (format, "('(F',I0,'.',I0,',A,I0,A)')") w, d mantissa = absval * 10._default ** (- e) write (cstr, fmt=format) mantissa, "\times 10^{", e, "}" end select string = sign // trim (cstr) end if end function tex_format @ %def tex_format @ \subsection{Metapost-compatible Output} Write a number for use in Metapost code: <>= public :: mp_format <>= module function mp_format (rval) result (string) type(string_t) :: string real(default), intent(in) :: rval end function mp_format <>= module function mp_format (rval) result (string) type(string_t) :: string real(default), intent(in) :: rval character(16) :: tmp write (tmp, "(G16.8)") rval string = lower_case (trim (adjustl (trim (tmp)))) end function mp_format @ %def mp_format @ \subsection{Conditional Formatting} Conditional format string, intended for switchable numeric precision. <>= public :: pac_fmt <>= module subroutine pac_fmt (fmt, fmt_orig, fmt_pac, pacify) character(*), intent(in) :: fmt_orig, fmt_pac character(*), intent(out) :: fmt logical, intent(in), optional :: pacify end subroutine pac_fmt <>= module subroutine pac_fmt (fmt, fmt_orig, fmt_pac, pacify) character(*), intent(in) :: fmt_orig, fmt_pac character(*), intent(out) :: fmt logical, intent(in), optional :: pacify logical :: pacified pacified = .false. if (present (pacify)) pacified = pacify if (pacified) then fmt = fmt_pac else fmt = fmt_orig end if end subroutine pac_fmt @ %def pac_fmt @ \subsection{Guard tiny values} This function can be applied if values smaller than $10^{-99}$ would cause an underflow in the output format. We know that Fortran fixed-format can handle this by omitting the exponent letter, but we should expect non-Fortran or Fortran list-directed input, which would fail. We reset such values to $\pm 10^{-99}$, assuming that such tiny values would not matter, except for being non-zero. <>= public :: refmt_tiny <>= elemental module function refmt_tiny (val) result (trunc_val) real(default), intent(in) :: val real(default) :: trunc_val end function refmt_tiny <>= elemental module function refmt_tiny (val) result (trunc_val) real(default), intent(in) :: val real(default) :: trunc_val real(default), parameter :: tiny_val = 1.e-99_default if (val /= 0) then if (abs (val) < tiny_val) then trunc_val = sign (tiny_val, val) else trunc_val = val end if else trunc_val = val end if end function refmt_tiny @ %def refmt_tiny @ \subsection{Compressed output of integer arrays} <>= public :: write_compressed_integer_array <>= module subroutine write_compressed_integer_array (chars, array) character(len=*), intent(out) :: chars integer, intent(in), allocatable, dimension(:) :: array end subroutine write_compressed_integer_array <>= module subroutine write_compressed_integer_array (chars, array) character(len=*), intent(out) :: chars integer, intent(in), allocatable, dimension(:) :: array logical, dimension(:), allocatable :: used character(len=16) :: tmp type(string_t) :: string integer :: i, j, start_chain, end_chain chars = '[none]' string = "" if (allocated (array)) then if (size (array) > 0) then allocate (used (size (array))) used = .false. do i = 1, size (array) if (.not. used(i)) then start_chain = array(i) end_chain = array(i) used(i) = .true. EXTEND: do do j = 1, size (array) if (array(j) == end_chain + 1) then end_chain = array(j) used(j) = .true. cycle EXTEND end if if (array(j) == start_chain - 1) then start_chain = array(j) used(j) = .true. cycle EXTEND end if end do exit end do EXTEND if (end_chain - start_chain > 0) then write (tmp, "(I0,A,I0)") start_chain, "-", end_chain else write (tmp, "(I0)") start_chain end if string = string // trim (tmp) if (any (.not. used)) then string = string // ',' end if end if end do chars = string end if end if chars = adjustr (chars) end subroutine write_compressed_integer_array @ %def write_compressed_integer_array %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Format Definitions} This module provides named integer parameters that specify certain format strings, used for numerical output. <<[[format_defs.f90]]>>= <> module format_defs <> <> end module format_defs @ %def format_defs @ We collect format strings for various numerical output formats here. <>= character(*), parameter, public :: FMT_19 = "ES19.12" character(*), parameter, public :: FMT_18 = "ES18.11" character(*), parameter, public :: FMT_17 = "ES17.10" character(*), parameter, public :: FMT_16 = "ES16.9" character(*), parameter, public :: FMT_15 = "ES15.8" character(*), parameter, public :: FMT_14 = "ES14.7" character(*), parameter, public :: FMT_13 = "ES13.6" character(*), parameter, public :: FMT_12 = "ES12.5" character(*), parameter, public :: FMT_11 = "ES11.4" character(*), parameter, public :: FMT_10 = "ES10.3" @ %def FMT_10 FMT_11 FMT_12 FMT_13 FMT_14 @ %def FMT_15 FMT_16 FMT_17 FMT_18 FMT_19 @ Fixed-point formats for better readability, where appropriate. <>= character(*), parameter, public :: FMF_12 = "F12.9" @ %def FMF_12 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Numeric Utilities} <<[[numeric_utils.f90]]>>= <> module numeric_utils <> <> <> <> <> <> <> interface <> end interface end module numeric_utils @ %def numeric_utils @ <<[[numeric_utils_sub.f90]]>>= <> submodule (numeric_utils) numeric_utils_s use string_utils use constants use format_defs implicit none contains <> end submodule numeric_utils_s @ %def numeric_utils_s +@ Probably, there needs to be a single, global workspace for the whole +calculations and not one local to the integration routine. +<>= + type :: int_workspace_t + private + integer :: limit + integer :: size = 0 + integer :: nrmax = 1 + integer :: i = 1 + integer :: maximum_level = 0 + real(default), dimension(:), allocatable :: alist + real(default), dimension(:), allocatable :: blist + real(default), dimension(:), allocatable :: rlist + real(default), dimension(:), allocatable :: elist + integer, dimension(:), allocatable :: order + integer, dimension(:), allocatable :: level + contains + <> + end type int_workspace_t + +@ %def int_workspace_t +@ +<>= + procedure :: init => int_workspace_init +<>= + module subroutine int_workspace_init (work, a, b, limit) + class(int_workspace_t), intent(out) :: work + real(default), intent(in) :: a, b + integer, intent(in) :: limit + end subroutine int_workspace_init +<>= + module subroutine int_workspace_init (work, a, b, limit) + class(int_workspace_t), intent(out) :: work + real(default), intent(in) :: a, b + integer, intent(in) :: limit + work%limit = limit + allocate (work%alist (limit), work%blist (limit), & + work%rlist (limit), work%elist(limit), & + work%order(limit), work%level(limit)) + work%alist(1) = a + work%blist(1) = b + end subroutine int_workspace_init + +@ %def int_workspace_init +@ +<>= + procedure :: set_initial => int_workspace_set_initial +<>= + module subroutine int_workspace_set_initial (work, res, err) + class(int_workspace_t), intent(inout) :: work + real(default), intent(in) :: res, err + end subroutine int_workspace_set_initial +<>= + module subroutine int_workspace_set_initial (work, res, err) + class(int_workspace_t), intent(inout) :: work + real(default), intent(in) :: res, err + work%size = 1 + work%order(1) = 1 + work%rlist(1) = res + work%elist(1) = err + end subroutine int_workspace_set_initial + +@ %def int_workspace_set_initial +@ +<>= + procedure :: update => int_workspace_update +<>= + module subroutine int_workspace_update (work, a1, b1, area1, error1, & + a2, b2, area2, error2) + class(int_workspace_t), intent(inout) :: work + real(default), intent(in) :: a1, b1, area1, error1, & + a2, b2, area2, error2 + end subroutine int_workspace_update +<>= + module subroutine int_workspace_update (work, a1, b1, area1, error1, & + a2, b2, area2, error2) + class(int_workspace_t), intent(inout) :: work + real(default), intent(in) :: a1, b1, area1, error1, & + a2, b2, area2, error2 + integer :: i_max, i_new, new_level + i_max = work%i + i_new = work%size + 1 + new_level = work%level(i_max) + 1 + ! append the newly-created intervals to the list + if (error2 > error1) then + ! work%blist(maxerr) is already b2 + work%alist(i_max) = a2 + work%rlist(i_max) = area2 + work%elist(i_max) = error2 + work%level(i_max) = new_level + work%alist(i_new) = a1 + work%blist(i_new) = b1 + work%rlist(i_new) = area1 + work%elist(i_new) = error1 + work%level(i_new) = new_level + else + ! work%alist(maxerr) is already a1 + work%blist(i_max) = b1 + work%rlist(i_max) = area1 + work%elist(i_max) = error1 + work%level(i_max) = new_level + work%alist(i_new) = a2 + work%blist(i_new) = b2 + work%rlist(i_new) = area2 + work%elist(i_new) = error2 + work%level(i_new) = new_level + end if + work%size = work%size + 1 + if (new_level > work%maximum_level) & + work%maximum_level = new_level + call work%sort () + end subroutine int_workspace_update + +@ %def int_workspace_update +@ +<>= + procedure :: sort => int_workspace_sort +<>= + module subroutine int_workspace_sort (work) + class(int_workspace_t), intent(inout) :: work + end subroutine int_workspace_sort +<>= + module subroutine int_workspace_sort (work) + class(int_workspace_t), intent(inout) :: work + integer :: last, limit, i, k, top, i_nrmax, i_maxerr + real(default) :: errmax, errmin + last = work%size + limit = work%limit + i_nrmax = work%nrmax + i_maxerr = work%order(i_nrmax) + ! Check whether the list contains more than two error estimates + if (last < 3) then + work%order(1) = 1 + work%order(2) = 2 + work%i = i_maxerr + return + end if + errmax = work%elist(i_maxerr) + ! This part of the routine is only executed if, due to a difficult + ! integrand, subdivision increased the error estimate. In the normal + ! case the insert procedure should start after the nrmax-th largest + ! error estimate. + DESCEND_NRMAX: do while (i_nrmax > 1) + if (errmax > work%elist(work%order(i_nrmax - 1))) then + work%order(i_nrmax) = work%order(i_nrmax - 1) + i_nrmax = i_nrmax - 1 + else + exit DESCEND_NRMAX + end if + end do DESCEND_NRMAX + ! Compute the number of elements in the list to be maintained in + ! descending order. This number depends on the number of + ! subdivisions still allowed. + if (last < (limit/2 + 2)) then + top = last + else + top = limit - last + 1 + end if + ! Insert errmax by traversing the list top-down, starting + ! comparison from the element elist(order(i_nrmax+1)). + i = i_nrmax + 1 + ! The order of the tests in the following line is important to + ! prevent a segmentation fault + ASCEND_TOP: do while (i < top) + if (errmax < work%elist(work%order(i))) then + work%order(i-1) = work%order(i) + i = i + 1 + else + exit ASCEND_TOP + end if + end do ASCEND_TOP + work%order(i-1) = i_maxerr + ! Insert errmin by traversing the list bottom-up + errmin = work%elist(last) + k = top - 1 + DESCEND_K: do while (k > i-2) + if (errmin >= work%elist(work%order(k))) then + work%order(k+1) = work%order(k) + k = k - 1 + else + exit DESCEND_K + end if + end do DESCEND_K + work%order(k+1) = last + ! Set i_max and e_max + i_maxerr = work%order(i_nrmax) + work%i = i_maxerr + work%nrmax = i_nrmax + end subroutine int_workspace_sort + +@ %def int_workspace_sort @ <>= public :: assert <>= module subroutine assert (unit, ok, description, exit_on_fail) integer, intent(in) :: unit logical, intent(in) :: ok character(*), intent(in), optional :: description logical, intent(in), optional :: exit_on_fail end subroutine assert <>= module subroutine assert (unit, ok, description, exit_on_fail) integer, intent(in) :: unit logical, intent(in) :: ok character(*), intent(in), optional :: description logical, intent(in), optional :: exit_on_fail logical :: ef ef = .false.; if (present (exit_on_fail)) ef = exit_on_fail if (.not. ok) then if (present(description)) then write (unit, "(A)") "* FAIL: " // description else write (unit, "(A)") "* FAIL: Assertion error" end if if (ef) stop 1 end if end subroutine assert @ %def assert @ Compare numbers and output error message if not equal. <>= public:: assert_equal interface assert_equal module procedure assert_equal_integer, assert_equal_integers, & assert_equal_real, assert_equal_reals, & assert_equal_complex, assert_equal_complexs end interface @ <>= module subroutine assert_equal_integer (unit, lhs, rhs, description, exit_on_fail) integer, intent(in) :: unit integer, intent(in) :: lhs, rhs character(*), intent(in), optional :: description logical, intent(in), optional :: exit_on_fail end subroutine assert_equal_integer <>= module subroutine assert_equal_integer (unit, lhs, rhs, description, exit_on_fail) integer, intent(in) :: unit integer, intent(in) :: lhs, rhs character(*), intent(in), optional :: description logical, intent(in), optional :: exit_on_fail type(string_t) :: desc logical :: ok ok = lhs == rhs desc = ''; if (present (description)) desc = var_str(description) // ": " call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail) end subroutine assert_equal_integer @ %def assert_equal_integer @ <>= module subroutine assert_equal_integers (unit, lhs, rhs, description, exit_on_fail) integer, intent(in) :: unit integer, dimension(:), intent(in) :: lhs, rhs character(*), intent(in), optional :: description logical, intent(in), optional :: exit_on_fail end subroutine assert_equal_integers <>= module subroutine assert_equal_integers (unit, lhs, rhs, description, exit_on_fail) integer, intent(in) :: unit integer, dimension(:), intent(in) :: lhs, rhs character(*), intent(in), optional :: description logical, intent(in), optional :: exit_on_fail type(string_t) :: desc logical :: ok ok = all(lhs == rhs) desc = ''; if (present (description)) desc = var_str(description) // ": " call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail) end subroutine assert_equal_integers @ %def assert_equal_integers @ <>= module subroutine assert_equal_real (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit real(default), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail end subroutine assert_equal_real <>= module subroutine assert_equal_real (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit real(default), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail type(string_t) :: desc logical :: ok ok = nearly_equal (lhs, rhs, abs_smallness, rel_smallness) desc = ''; if (present (description)) desc = var_str(description) // ": " call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail) end subroutine assert_equal_real @ %def assert_equal_real @ <>= module subroutine assert_equal_reals (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit real(default), dimension(:), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail end subroutine assert_equal_reals <>= module subroutine assert_equal_reals (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit real(default), dimension(:), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail type(string_t) :: desc logical :: ok ok = all(nearly_equal (lhs, rhs, abs_smallness, rel_smallness)) desc = ''; if (present (description)) desc = var_str(description) // ": " call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail) end subroutine assert_equal_reals @ %def assert_equal_reals @ <>= module subroutine assert_equal_complex (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit complex(default), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail end subroutine assert_equal_complex <>= module subroutine assert_equal_complex (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit complex(default), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail type(string_t) :: desc logical :: ok ok = nearly_equal (real(lhs), real(rhs), abs_smallness, rel_smallness) & .and. nearly_equal (aimag(lhs), aimag(rhs), abs_smallness, rel_smallness) desc = ''; if (present (description)) desc = var_str(description) // ": " call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail) end subroutine assert_equal_complex @ %def assert_equal_complex @ <>= module subroutine assert_equal_complexs (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit complex(default), dimension(:), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail end subroutine assert_equal_complexs <>= module subroutine assert_equal_complexs (unit, lhs, rhs, description, & abs_smallness, rel_smallness, exit_on_fail) integer, intent(in) :: unit complex(default), dimension(:), intent(in) :: lhs, rhs character(*), intent(in), optional :: description real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: exit_on_fail type(string_t) :: desc logical :: ok ok = all (nearly_equal (real(lhs), real(rhs), abs_smallness, rel_smallness)) & .and. all (nearly_equal (aimag(lhs), aimag(rhs), abs_smallness, rel_smallness)) desc = ''; if (present (description)) desc = var_str(description) // ": " call assert (unit, ok, char(desc // str (lhs) // " /= " // str (rhs)), exit_on_fail) end subroutine assert_equal_complexs @ %def assert_equal_complexs @ Note that this poor man's check will be disabled if someone compiles with [[-ffast-math]] or similar optimizations. <>= elemental function ieee_is_nan (x) result (yorn) logical :: yorn real(default), intent(in) :: x yorn = (x /= x) end function ieee_is_nan @ %def ieee_is_nan @ This is still not perfect but should work in most cases. Usually one wants to compare to a relative epsilon [[rel_smallness]], except for numbers close to zero defined by [[abs_smallness]]. Both might need adaption to specific use cases but have reasonable defaults. <>= public :: nearly_equal <>= interface nearly_equal module procedure nearly_equal_real module procedure nearly_equal_complex end interface nearly_equal <>= elemental module function nearly_equal_real & (a, b, abs_smallness, rel_smallness) result (r) logical :: r real(default), intent(in) :: a, b real(default), intent(in), optional :: abs_smallness, rel_smallness end function nearly_equal_real <>= elemental module function nearly_equal_real & (a, b, abs_smallness, rel_smallness) result (r) logical :: r real(default), intent(in) :: a, b real(default), intent(in), optional :: abs_smallness, rel_smallness real(default) :: abs_a, abs_b, diff, abs_small, rel_small abs_a = abs (a) abs_b = abs (b) diff = abs (a - b) ! shortcut, handles infinities and nans if (a == b) then r = .true. return else if (ieee_is_nan (a) .or. ieee_is_nan (b) .or. ieee_is_nan (diff)) then r = .false. return end if abs_small = tiny_13; if (present (abs_smallness)) abs_small = abs_smallness rel_small = tiny_10; if (present (rel_smallness)) rel_small = rel_smallness if (abs_a < abs_small .and. abs_b < abs_small) then r = diff < abs_small else r = diff / max (abs_a, abs_b) < rel_small end if end function nearly_equal_real @ %def nearly_equal_real <>= elemental module function nearly_equal_complex & (a, b, abs_smallness, rel_smallness) result (r) logical :: r complex(default), intent(in) :: a, b real(default), intent(in), optional :: abs_smallness, rel_smallness end function nearly_equal_complex <>= elemental module function nearly_equal_complex & (a, b, abs_smallness, rel_smallness) result (r) logical :: r complex(default), intent(in) :: a, b real(default), intent(in), optional :: abs_smallness, rel_smallness r = nearly_equal_real (real (a), real (b), abs_smallness, rel_smallness) .and. & nearly_equal_real (aimag (a), aimag(b), abs_smallness, rel_smallness) end function nearly_equal_complex @ %def neary_equal_complex @ Often we will need to check whether floats vanish: <>= public:: vanishes interface vanishes module procedure vanishes_real, vanishes_complex end interface @ <>= elemental module function vanishes_real & (x, abs_smallness, rel_smallness) result (r) logical :: r real(default), intent(in) :: x real(default), intent(in), optional :: abs_smallness, rel_smallness end function vanishes_real elemental module function vanishes_complex & (x, abs_smallness, rel_smallness) result (r) logical :: r complex(default), intent(in) :: x real(default), intent(in), optional :: abs_smallness, rel_smallness end function vanishes_complex <>= elemental module function vanishes_real & (x, abs_smallness, rel_smallness) result (r) logical :: r real(default), intent(in) :: x real(default), intent(in), optional :: abs_smallness, rel_smallness r = nearly_equal (x, zero, abs_smallness, rel_smallness) end function vanishes_real elemental module function vanishes_complex & (x, abs_smallness, rel_smallness) result (r) logical :: r complex(default), intent(in) :: x real(default), intent(in), optional :: abs_smallness, rel_smallness r = vanishes_real (abs (x), abs_smallness, rel_smallness) end function vanishes_complex @ %def vanishes @ <>= public :: expanded_amp2 <>= pure module function expanded_amp2 (amp_tree, amp_blob) result (amp2) real(default) :: amp2 complex(default), dimension(:), intent(in) :: amp_tree, amp_blob end function expanded_amp2 <>= pure module function expanded_amp2 (amp_tree, amp_blob) result (amp2) real(default) :: amp2 complex(default), dimension(:), intent(in) :: amp_tree, amp_blob amp2 = sum (amp_tree * conjg (amp_tree) + & amp_tree * conjg (amp_blob) + & amp_blob * conjg (amp_tree)) end function expanded_amp2 @ %def expanded_amp2 @ <>= public :: abs2 <>= elemental module function abs2 (c) result (c2) real(default) :: c2 complex(default), intent(in) :: c end function abs2 <>= elemental module function abs2 (c) result (c2) real(default) :: c2 complex(default), intent(in) :: c c2 = real (c * conjg(c)) end function abs2 @ %def abs2 @ Remove element with [[index]] from array <>= public:: remove_array_element interface remove_array_element module procedure remove_array_element_logical end interface @ <>= module function remove_array_element_logical & (array, index) result (array_reduced) logical, intent(in), dimension(:) :: array integer, intent(in) :: index logical, dimension(:), allocatable :: array_reduced end function remove_array_element_logical <>= module function remove_array_element_logical & (array, index) result (array_reduced) logical, intent(in), dimension(:) :: array integer, intent(in) :: index logical, dimension(:), allocatable :: array_reduced integer :: i allocate (array_reduced(0)) do i = 1, size (array) if (i /= index) then array_reduced = [array_reduced, [array(i)]] end if end do end function remove_array_element_logical @ %def remove_array_element @ Remove all duplicates from an array of signed integers and returns an unordered array of remaining elements. This method does not really fit into this module. It could be part of a larger module which deals with array manipulations. <>= public :: remove_duplicates_from_int_array <>= module function remove_duplicates_from_int_array & (array) result (array_unique) integer, intent(in), dimension(:) :: array integer, dimension(:), allocatable :: array_unique end function remove_duplicates_from_int_array <>= module function remove_duplicates_from_int_array & (array) result (array_unique) integer, intent(in), dimension(:) :: array integer, dimension(:), allocatable :: array_unique integer :: i allocate (array_unique(0)) do i = 1, size (array) if (any (array_unique == array(i))) cycle array_unique = [array_unique, [array(i)]] end do end function remove_duplicates_from_int_array @ %def remove_duplicates_from_int_array @ <>= public :: extend_integer_array <>= module subroutine extend_integer_array (list, incr, initial_value) integer, intent(inout), dimension(:), allocatable :: list integer, intent(in) :: incr integer, intent(in), optional :: initial_value end subroutine extend_integer_array <>= module subroutine extend_integer_array (list, incr, initial_value) integer, intent(inout), dimension(:), allocatable :: list integer, intent(in) :: incr integer, intent(in), optional :: initial_value integer, dimension(:), allocatable :: list_store integer :: n, ini ini = 0; if (present (initial_value)) ini = initial_value n = size (list) allocate (list_store (n)) list_store = list deallocate (list) allocate (list (n+incr)) list(1:n) = list_store list(1+n : n+incr) = ini deallocate (list_store) end subroutine extend_integer_array @ %def extend_integer_array @ <>= public :: crop_integer_array <>= module subroutine crop_integer_array (list, i_crop) integer, intent(inout), dimension(:), allocatable :: list integer, intent(in) :: i_crop end subroutine crop_integer_array <>= module subroutine crop_integer_array (list, i_crop) integer, intent(inout), dimension(:), allocatable :: list integer, intent(in) :: i_crop integer, dimension(:), allocatable :: list_store allocate (list_store (i_crop)) list_store = list(1:i_crop) deallocate (list) allocate (list (i_crop)) list = list_store deallocate (list_store) end subroutine crop_integer_array @ %def crop_integer_array @ We also need an evaluation of $\log x$ which is stable near $x=1$. <>= public :: log_prec <>= module function log_prec (x, xb) result (lx) real(default), intent(in) :: x, xb real(default) :: lx end function log_prec <>= module function log_prec (x, xb) result (lx) real(default), intent(in) :: x, xb real(default) :: a1, a2, a3, lx a1 = xb a2 = a1 * xb / two a3 = a2 * xb * two / three if (abs (a3) < epsilon (a3)) then lx = - a1 - a2 - a3 else lx = log (x) end if end function log_prec @ %def log_prec @ <>= public :: split_array <>= interface split_array module procedure split_integer_array module procedure split_real_array end interface <>= module subroutine split_integer_array (list1, list2) integer, intent(inout), dimension(:), allocatable :: list1, list2 integer, dimension(:), allocatable :: list_store end subroutine split_integer_array module subroutine split_real_array (list1, list2) real(default), intent(inout), dimension(:), allocatable :: list1, list2 real(default), dimension(:), allocatable :: list_store end subroutine split_real_array <>= module subroutine split_integer_array (list1, list2) integer, intent(inout), dimension(:), allocatable :: list1, list2 integer, dimension(:), allocatable :: list_store allocate (list_store (size (list1) - size (list2))) list2 = list1(:size (list2)) list_store = list1 (size (list2) + 1:) deallocate (list1) allocate (list1 (size (list_store))) list1 = list_store deallocate (list_store) end subroutine split_integer_array module subroutine split_real_array (list1, list2) real(default), intent(inout), dimension(:), allocatable :: list1, list2 real(default), dimension(:), allocatable :: list_store allocate (list_store (size (list1) - size (list2))) list2 = list1(:size (list2)) list_store = list1 (size (list2) + 1:) deallocate (list1) allocate (list1 (size (list_store))) list1 = list_store deallocate (list_store) end subroutine split_real_array @ %def split_array @ +\subsection{Integration routines} +Gauss integration using the 41-point Gauss-Kronrod rule. +<>= + abstract interface + function g_func (x) result (f) + import default + real(default), intent(in) :: x + real(default) :: f + end function g_func + end interface +@ %def g_func +@ +<>= + public :: d1mach +<>= + module function d1mach (i) result (d1) + integer, intent(in) :: i + real(default) :: d1 + end function d1mach +<>= + module function d1mach (i) result (d1) + integer, intent(in) :: i + real(default) :: b, x + real(default) :: d1 + !***begin prologue d1mach + !***purpose return floating point machine dependent constants. + !***library slatec + !***category r1 + !***type single precision (d1mach-s, d1mach-d) + !***keywords machine constants + !***author fox, p. a., (bell labs) + ! hall, a. d., (bell labs) + ! schryer, n. l., (bell labs) + !***description + ! + ! d1mach can be used to obtain machine-dependent parameters for the + ! local machine environment. it is a function subprogram with one + ! (input) argument, and can be referenced as follows: + ! + ! a = d1mach(i) + ! + ! where i=1,...,5. the (output) value of a above is determined by + ! the (input) value of i. the results for various values of i are + ! discussed below. + ! + ! d1mach(1) = b**(emin-1), the smallest positive magnitude. + ! d1mach(2) = b**emax*(1 - b**(-t)), the largest magnitude. + ! d1mach(3) = b**(-t), the smallest relative spacing. + ! d1mach(4) = b**(1-t), the largest relative spacing. + ! d1mach(5) = log10(b) + ! + ! assume single precision numbers are represented in the t-digit, + ! base-b form + ! + ! sign (b**e)*( (x(1)/b) + ... + (x(t)/b**t) ) + ! + ! where 0 .le. x(i) .lt. b for i=1,...,t, 0 .lt. x(1), and + ! emin .le. e .le. emax. + ! + ! the values of b, t, emin and emax are provided in i1mach as + ! follows: + ! i1mach(10) = b, the base. + ! i1mach(11) = t, the number of base-b digits. + ! i1mach(12) = emin, the smallest exponent e. + ! i1mach(13) = emax, the largest exponent e. + ! + ! + !***references p. a. fox, a. d. hall and n. l. schryer, framework for + ! a portable library, acm transactions on mathematical + ! software 4, 2 (june 1978), pp. 177-188. + !***routines called xemsgr + !***revision history (yymmdd) + ! 790101 date written + ! 960329 modified for fortran 90 (be after suggestions by ehg) + !***end prologue d1mach + ! + x = 1.0_default + b = radix(x) + select case (i) + case (1) + d1 = b**(minexponent(x)-1) ! the smallest positive magnitude. + case (2) + d1 = huge(X) ! the largest magnitude. + case (3) + d1 = b**(-digits(x)) ! the smallest relative spacing. + case (4) + d1 = b**(1-digits(x)) ! the largest relative spacing. + case (5) + d1 = log10(b) + case default + d1 = b**(minexponent(x)-1) + end select + end function d1mach + +@ %def d1mach +@ +<>= + public :: dqk41 +<>= + module subroutine dqk41 (f, a, b, result, abserr, resabs, resasc) + procedure(g_func) :: f + real(default), intent(in) :: a, b + real(default), intent(out) :: result, abserr, resabs, resasc + end subroutine dqk41 +<>= + module subroutine dqk41 (f, a, b, result, abserr, resabs, resasc) + !c***begin prologue dqk41 + !c***date written 800101 (yymmdd) + !c***revision date 830518 (yymmdd) + !c***category no. h2a1a2 + !c***keywords 41-point gauss-kronrod rules + !c***author piessens,robert,appl. math. & progr. div. - k.u.leuven + !c de doncker,elise,appl. math. & progr. div. - k.u.leuven + !c***purpose to compute i = integral of f over (a,b), with error + !c estimate + !c j = integral of abs(f) over (a,b) + !c***description + !c + !c integration rules + !c standard fortran subroutine + !c double precision version + !c + !c parameters + !c on entry + !c f - double precision + !c function subprogram defining the integrand + !c function f(x). the actual name for f needs to be + !c declared e x t e r n a l in the calling program. + !c + !c a - double precision + !c lower limit of integration + !c + !c b - double precision + !c upper limit of integration + !c + !c on return + !c result - double precision + !c approximation to the integral i + !c result is computed by applying the 41-point + !c gauss-kronrod rule (resk) obtained by optimal + !c addition of abscissae to the 20-point gauss + !c rule (resg). + !c + !c abserr - double precision + !c estimate of the modulus of the absolute error, + !c which should not exceed abs(i-result) + !c + !c resabs - double precision + !c approximation to the integral j + !c + !c resasc - double precision + !c approximation to the integal of abs(f-i/(b-a)) + !c over (a,b) + !c + !c***references (none) + !c***routines called d1mach + !c***end prologue dqk41 + procedure(g_func) :: f + real(default), intent(in) :: a, b + real(default), intent(out) :: result, abserr, resabs, resasc + real(default) :: absc, centr, dhlgth, dmax1, dmin1, & + epmach, fc, fsum, fval1, fval2, hlgth, & + resg, resk, reskh, uflow + real(default), dimension(20) :: fv1, fv2 + real(default), dimension(21) :: xgk, wgk + real(default), dimension(10) :: wg + integer :: j, jtw, jtwm1 + ! the abscissae and weights are given for the interval (-1,1). + ! because of symmetry only the positive abscissae and their + ! corresponding weights are given. + ! + ! xgk - abscissae of the 41-point gauss-kronrod rule + ! xgk(2), xgk(4), ... abscissae of the 20-point + ! gauss rule + ! xgk(1), xgk(3), ... abscissae which are optimally + ! added to the 20-point gauss rule + ! + ! wgk - weights of the 41-point gauss-kronrod rule + ! + ! wg - weights of the 20-point gauss rule + ! + ! + ! gauss quadrature weights and kronron quadrature abscissae and weights + ! as evaluated with 80 decimal digit arithmetic by l. w. fullerton, + ! bell labs, nov. 1981. + ! + data wg ( 1) / 0.017614007139152118311861962351853_default / + data wg ( 2) / 0.040601429800386941331039952274932_default / + data wg ( 3) / 0.062672048334109063569506535187042_default / + data wg ( 4) / 0.083276741576704748724758143222046_default / + data wg ( 5) / 0.101930119817240435036750135480350_default / + data wg ( 6) / 0.118194531961518417312377377711382_default / + data wg ( 7) / 0.131688638449176626898494499748163_default / + data wg ( 8) / 0.142096109318382051329298325067165_default / + data wg ( 9) / 0.149172986472603746787828737001969_default / + data wg ( 10) / 0.152753387130725850698084331955098_default / + + data xgk ( 1) / 0.998859031588277663838315576545863_default / + data xgk ( 2) / 0.993128599185094924786122388471320_default / + data xgk ( 3) / 0.981507877450250259193342994720217_default / + data xgk ( 4) / 0.963971927277913791267666131197277_default / + data xgk ( 5) / 0.940822633831754753519982722212443_default / + data xgk ( 6) / 0.912234428251325905867752441203298_default / + data xgk ( 7) / 0.878276811252281976077442995113078_default / + data xgk ( 8) / 0.839116971822218823394529061701521_default / + data xgk ( 9) / 0.795041428837551198350638833272788_default / + data xgk ( 10) / 0.746331906460150792614305070355642_default / + data xgk ( 11) / 0.693237656334751384805490711845932_default / + data xgk ( 12) / 0.636053680726515025452836696226286_default / + data xgk ( 13) / 0.575140446819710315342946036586425_default / + data xgk ( 14) / 0.510867001950827098004364050955251_default / + data xgk ( 15) / 0.443593175238725103199992213492640_default / + data xgk ( 16) / 0.373706088715419560672548177024927_default / + data xgk ( 17) / 0.301627868114913004320555356858592_default / + data xgk ( 18) / 0.227785851141645078080496195368575_default / + data xgk ( 19) / 0.152605465240922675505220241022678_default / + data xgk ( 20) / 0.076526521133497333754640409398838_default / + data xgk ( 21) / 0.000000000000000000000000000000000_default / + + data wgk ( 1) / 0.003073583718520531501218293246031_default / + data wgk ( 2) / 0.008600269855642942198661787950102_default / + data wgk ( 3) / 0.014626169256971252983787960308868_default / + data wgk ( 4) / 0.020388373461266523598010231432755_default / + data wgk ( 5) / 0.025882133604951158834505067096153_default / + data wgk ( 6) / 0.031287306777032798958543119323801_default / + data wgk ( 7) / 0.036600169758200798030557240707211_default / + data wgk ( 8) / 0.041668873327973686263788305936895_default / + data wgk ( 9) / 0.046434821867497674720231880926108_default / + data wgk ( 10) / 0.050944573923728691932707670050345_default / + data wgk ( 11) / 0.055195105348285994744832372419777_default / + data wgk ( 12) / 0.059111400880639572374967220648594_default / + data wgk ( 13) / 0.062653237554781168025870122174255_default / + data wgk ( 14) / 0.065834597133618422111563556969398_default / + data wgk ( 15) / 0.068648672928521619345623411885368_default / + data wgk ( 16) / 0.071054423553444068305790361723210_default / + data wgk ( 17) / 0.073030690332786667495189417658913_default / + data wgk ( 18) / 0.074582875400499188986581418362488_default / + data wgk ( 19) / 0.075704497684556674659542775376617_default / + data wgk ( 20) / 0.076377867672080736705502835038061_default / + data wgk ( 21) / 0.076600711917999656445049901530102_default / + ! + ! + ! list of major variables + ! ----------------------- + ! + ! centr - mid point of the interval + ! hlgth - half-length of the interval + ! absc - abscissa + ! fval* - function value + ! resg - result of the 20-point gauss formula + ! resk - result of the 41-point kronrod formula + ! reskh - approximation to mean value of f over (a,b), i.e. + ! to i/(b-a) + ! + ! machine dependent constants + ! --------------------------- + ! + ! epmach is the largest relative spacing. + ! uflow is the smallest positive magnitude. + ! + !***first executable statement dqk41 + epmach = d1mach(4) + uflow = d1mach(1) + + centr = 0.5d+00*(a+b) + hlgth = 0.5d+00*(b-a) + dhlgth = abs(hlgth) + ! + ! compute the 41-point gauss-kronrod approximation to + ! the integral, and estimate the absolute error. + ! + resg = 0.0d+00 + fc = f(centr) + resk = wgk(21)*fc + resabs = abs(resk) + do j = 1, 10 + jtw = j*2 + absc = hlgth*xgk(jtw) + fval1 = f(centr-absc) + fval2 = f(centr+absc) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*(abs(fval1)+abs(fval2)) + end do + do j = 1,10 + jtwm1 = j*2-1 + absc = hlgth*xgk(jtwm1) + fval1 = f(centr-absc) + fval2 = f(centr+absc) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*(abs(fval1)+abs(fval2)) + end do + reskh = resk*0.5d+00 + resasc = wgk(21)*abs(fc-reskh) + do j = 1, 20 + resasc = resasc+wgk(j)*(abs(fv1(j)-reskh)+abs(fv2(j)-reskh)) + end do + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = abs((resk-resg)*hlgth) + if (resasc.ne.0.0d+00.and.abserr.ne.0.d+00) & + abserr = resasc*dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00) + if (resabs.gt.uflow/(0.5d+02*epmach)) abserr = dmax1 & + ((epmach*0.5d+02)*resabs,abserr) + end subroutine dqk41 + +@ %def dqk41 +@ +<>= + public :: dqk61 +<>= + module subroutine dqk61 (f, a, b, result, abserr, resabs, resasc) + procedure(g_func) :: f + real(default), intent(in) :: a, b + real(default), intent(out) :: result, abserr, resabs, resasc + end subroutine dqk61 +<>= + module subroutine dqk61 (f, a, b, result, abserr, resabs, resasc) + !c***begin prologue dqk61 + !c***purpose to compute i = integral of f over (a,b) with error + !c estimate + !c j = integral of abs(f) over (a,b) + !c***library slatec (quadpack) + !c***category h2a1a2 + !c***type double precision (qk61-s, dqk61-d) + !c***keywords 61-point gauss-kronrod rules, quadpack, quadrature + !c***author piessens, robert + !c applied mathematics and programming division + !c k. u. leuven + !c de doncker, elise + !c applied mathematics and programming division + !c k. u. leuven + !c***description + !c + !c integration rule + !c standard fortran subroutine + !c double precision version + !c + !c + !c parameters + !c on entry + !c f - double precision + !c function subprogram defining the integrand + !c function f(x). the actual name for f needs to be + !c declared e x t e r n a l in the calling program. + !c + !c a - double precision + !c lower limit of integration + !c + !c b - double precision + !c upper limit of integration + !c + !c on return + !c result - double precision + !c approximation to the integral i + !c result is computed by applying the 61-point + !c kronrod rule (resk) obtained by optimal addition of + !c abscissae to the 30-point gauss rule (resg). + !c + !c abserr - double precision + !c estimate of the modulus of the absolute error, + !c which should equal or exceed abs(i-result) + !c + !c resabs - double precision + !c approximation to the integral j + !c + !c resasc - double precision + !c approximation to the integral of abs(f-i/(b-a)) + !c + !c***references (none) + !c***routines called d1mach + !c***revision history (yymmdd) + !c 800101 date written + !c 890531 changed all specific intrinsics to generic. (wrb) + !c 890531 revision date from version 3.2 + !c 891214 prologue converted to version 4.0 format. (bab) + !c***end prologue dqk61 + !c + procedure(g_func) :: f + real(default), intent(in) :: a, b + real(default), intent(out) :: result, abserr, resabs, resasc + real(default) :: absc, centr, dhlgth, & + epmach, fc, fsum, fval1, fval2, hlgth, & + resg, resk, reskh, uflow + real(default), dimension(30) :: fv1, fv2 + real(default), dimension(31) :: xgk, wgk + real(default), dimension(15) :: wg + integer :: j, jtw, jtwm1 + ! + ! the abscissae and weights are given for the + ! interval (-1,1). because of symmetry only the positive + ! abscissae and their corresponding weights are given. + ! + ! xgk - abscissae of the 61-point kronrod rule + ! xgk(2), xgk(4) ... abscissae of the 30-point + ! gauss rule + ! xgk(1), xgk(3) ... optimally added abscissae + ! to the 30-point gauss rule + ! + ! wgk - weights of the 61-point kronrod rule + ! + ! wg - weights of the 30-point gauss rule + ! + ! + ! gauss quadrature weights and kronrod quadrature abscissae and weights + ! as evaluated with 80 decimal digit arithmetic by l. w. fullerton, + ! bell labs, nov. 1981. + ! + data wg ( 1) / 0.007968192496166605615465883474674_default / + data wg ( 2) / 0.018466468311090959142302131912047_default / + data wg ( 3) / 0.028784707883323369349719179611292_default / + data wg ( 4) / 0.038799192569627049596801936446348_default / + data wg ( 5) / 0.048402672830594052902938140422808_default / + data wg ( 6) / 0.057493156217619066481721689402056_default / + data wg ( 7) / 0.065974229882180495128128515115962_default / + data wg ( 8) / 0.073755974737705206268243850022191_default / + data wg ( 9) / 0.080755895229420215354694938460530_default / + data wg ( 10) / 0.086899787201082979802387530715126_default / + data wg ( 11) / 0.092122522237786128717632707087619_default / + data wg ( 12) / 0.096368737174644259639468626351810_default / + data wg ( 13) / 0.099593420586795267062780282103569_default / + data wg ( 14) / 0.101762389748405504596428952168554_default / + data wg ( 15) / 0.102852652893558840341285636705415_default / + + data xgk ( 1) / 0.999484410050490637571325895705811_default / + data xgk ( 2) / 0.996893484074649540271630050918695_default / + data xgk ( 3) / 0.991630996870404594858628366109486_default / + data xgk ( 4) / 0.983668123279747209970032581605663_default / + data xgk ( 5) / 0.973116322501126268374693868423707_default / + data xgk ( 6) / 0.960021864968307512216871025581798_default / + data xgk ( 7) / 0.944374444748559979415831324037439_default / + data xgk ( 8) / 0.926200047429274325879324277080474_default / + data xgk ( 9) / 0.905573307699907798546522558925958_default / + data xgk ( 10) / 0.882560535792052681543116462530226_default / + data xgk ( 11) / 0.857205233546061098958658510658944_default / + data xgk ( 12) / 0.829565762382768397442898119732502_default / + data xgk ( 13) / 0.799727835821839083013668942322683_default / + data xgk ( 14) / 0.767777432104826194917977340974503_default / + data xgk ( 15) / 0.733790062453226804726171131369528_default / + data xgk ( 16) / 0.697850494793315796932292388026640_default / + data xgk ( 17) / 0.660061064126626961370053668149271_default / + data xgk ( 18) / 0.620526182989242861140477556431189_default / + data xgk ( 19) / 0.579345235826361691756024932172540_default / + data xgk ( 20) / 0.536624148142019899264169793311073_default / + data xgk ( 21) / 0.492480467861778574993693061207709_default / + data xgk ( 22) / 0.447033769538089176780609900322854_default / + data xgk ( 23) / 0.400401254830394392535476211542661_default / + data xgk ( 24) / 0.352704725530878113471037207089374_default / + data xgk ( 25) / 0.304073202273625077372677107199257_default / + data xgk ( 26) / 0.254636926167889846439805129817805_default / + data xgk ( 27) / 0.204525116682309891438957671002025_default / + data xgk ( 28) / 0.153869913608583546963794672743256_default / + data xgk ( 29) / 0.102806937966737030147096751318001_default / + data xgk ( 30) / 0.051471842555317695833025213166723_default / + data xgk ( 31) / 0.000000000000000000000000000000000_default / + + data wgk ( 1) / 0.001389013698677007624551591226760_default / + data wgk ( 2) / 0.003890461127099884051267201844516_default / + data wgk ( 3) / 0.006630703915931292173319826369750_default / + data wgk ( 4) / 0.009273279659517763428441146892024_default / + data wgk ( 5) / 0.011823015253496341742232898853251_default / + data wgk ( 6) / 0.014369729507045804812451432443580_default / + data wgk ( 7) / 0.016920889189053272627572289420322_default / + data wgk ( 8) / 0.019414141193942381173408951050128_default / + data wgk ( 9) / 0.021828035821609192297167485738339_default / + data wgk ( 10) / 0.024191162078080601365686370725232_default / + data wgk ( 11) / 0.026509954882333101610601709335075_default / + data wgk ( 12) / 0.028754048765041292843978785354334_default / + data wgk ( 13) / 0.030907257562387762472884252943092_default / + data wgk ( 14) / 0.032981447057483726031814191016854_default / + data wgk ( 15) / 0.034979338028060024137499670731468_default / + data wgk ( 16) / 0.036882364651821229223911065617136_default / + data wgk ( 17) / 0.038678945624727592950348651532281_default / + data wgk ( 18) / 0.040374538951535959111995279752468_default / + data wgk ( 19) / 0.041969810215164246147147541285970_default / + data wgk ( 20) / 0.043452539701356069316831728117073_default / + data wgk ( 21) / 0.044814800133162663192355551616723_default / + data wgk ( 22) / 0.046059238271006988116271735559374_default / + data wgk ( 23) / 0.047185546569299153945261478181099_default / + data wgk ( 24) / 0.048185861757087129140779492298305_default / + data wgk ( 25) / 0.049055434555029778887528165367238_default / + data wgk ( 26) / 0.049795683427074206357811569379942_default / + data wgk ( 27) / 0.050405921402782346840893085653585_default / + data wgk ( 28) / 0.050881795898749606492297473049805_default / + data wgk ( 29) / 0.051221547849258772170656282604944_default / + data wgk ( 30) / 0.051426128537459025933862879215781_default / + data wgk ( 31) / 0.051494729429451567558340433647099_default / + ! + ! list of major variables + ! ----------------------- + ! + ! centr - mid point of the interval + ! hlgth - half-length of the interval + ! absc - abscissa + ! fval* - function value + ! resg - result of the 30-point gauss rule + ! resk - result of the 61-point kronrod rule + ! reskh - approximation to the mean value of f + ! over (a,b), i.e. to i/(b-a) + ! + ! machine dependent constants + ! --------------------------- + ! + ! epmach is the largest relative spacing. + ! uflow is the smallest positive magnitude. + ! + !***first executable statement dqk61 + epmach = d1mach(4) + uflow = d1mach(1) + + centr = 0.5d+00*(b+a) + hlgth = 0.5d+00*(b-a) + dhlgth = abs(hlgth) + ! + ! compute the 61-point kronrod approximation to the + ! integral, and estimate the absolute error. + ! + resg = 0.0d+00 + fc = f(centr) + resk = wgk(31)*fc + resabs = abs(resk) + do j = 1, 15 + jtw = j*2 + absc = hlgth*xgk(jtw) + fval1 = f(centr-absc) + fval2 = f(centr+absc) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*(abs(fval1)+abs(fval2)) + end do + do j = 1, 15 + jtwm1 = j*2-1 + absc = hlgth*xgk(jtwm1) + fval1 = f(centr-absc) + fval2 = f(centr+absc) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*(abs(fval1)+abs(fval2)) + end do + reskh = resk*0.5d+00 + resasc = wgk(31)*abs(fc-reskh) + do j = 1, 30 + RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH)) + end do + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = abs((resk-resg)*hlgth) + if (resasc.ne.0.0d+00.and.abserr.ne.0.0d+00) & + abserr = resasc*min(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00) + if (resabs.gt.uflow/(0.5d+02*epmach)) abserr = max & + ((epmach*0.5d+02)*resabs,abserr) + end subroutine dqk61 + +@ %def dqk61 +@ +<>= + integer, parameter, public :: GAUSS_KRONROD_41 = 41, GAUSS_KRONROD_61 = 61 +<>= + public :: gauss_kronrod +<>= + module subroutine gauss_kronrod & + (type, f, a, b, limit, result, abserr, epsabs, epsrel) + integer, intent(in) :: type + procedure(g_func) :: f + real(default), intent(in) :: a, b + real(default), intent(in) :: epsabs, epsrel + real(default), intent(out) :: result, abserr + integer, intent(in) :: limit + end subroutine gauss_kronrod +<>= + module subroutine gauss_kronrod & + (type, f, a, b, limit, result, abserr, epsabs, epsrel) + integer, intent(in) :: type + procedure(g_func) :: f + real(default), intent(in) :: a, b + real(default), intent(in) :: epsabs, epsrel + real(default), intent(out) :: result, abserr + integer, intent(in) :: limit + real(default) :: area, errsum + real(default) :: tolerance_g, round_off + real(default) :: result0, abserr0, resabs0, resasc0 + type(int_workspace_t) :: work + real(default) :: a1, b1, a2, b2, a_i, b_i, r_i, e_i + real(default) :: area1, area2, area12, error1, error2, error12 + real(default) :: resasc1, resasc2, resabs1, resabs2, delta + integer :: i, iteration + integer :: roundoff_type1, roundoff_type2 + !!! epsilon(dbl) + real(default), parameter :: dbl_prec = 2.2204460492503131e-16_default + !!! tiny(dbl) + real(default), parameter :: dbl_min = 2.2250738585072014e-308_default + iteration = 0 + if (epsabs <= 0) then + if (epsrel < 50 * dbl_prec .or. epsrel < 0.5e-28_default) then + error stop ("Gauss_Kronrod: tolerance cannot be achieved with given " & + // "epsabs and epsrel") + end if + end if + call work%init (a, b, limit) + ! Perform the first integration + select case (type) + case (GAUSS_KRONROD_61) + call dqk61 (f, a, b, result0, abserr0, resabs0, resasc0) + case default + call dqk41 (f, a, b, result0, abserr0, resabs0, resasc0) + end select + call work%set_initial (result0, abserr0) + ! Test on accuracy + tolerance_g = max (epsabs, epsrel * abs(result0)) + round_off = 50 * dbl_prec * resabs0 + if (abserr0 <= round_off .and. abserr0 > tolerance_g) then + result = result0 + abserr = abserr0 + error stop ("Gauss_Kronrod: cannot reach tolerance because of roundoff " & + // "error on first attempt") + else if ((abserr0 <= tolerance_g .and. abserr0 /= resasc0) .or. & + abserr0 == 0.0_default) then + result = result0 + abserr = abserr0 + return + else if (limit == 1) then + result = result0 + abserr = abserr0 + error stop ("Gauss_Kronrod: a maximum of one iteration was insufficient") + end if + area = result0 + errsum = abserr0 + roundoff_type1 = 0 + roundoff_type2 = 0 + ITERATION_LOOP: do iteration = 1, limit + a_i = work%alist(work%i) + b_i = work%blist(work%i) + r_i = work%rlist(work%i) + e_i = work%elist(work%i) + a1 = a_i + b1 = 0.5_default * (a_i + b_i) + a2 = b1 + b2 = b_i + select case (type) + case (GAUSS_KRONROD_61) + call dqk61 (f, a1, b1, area1, error1, resabs1, resasc1) + call dqk61 (f, a2, b2, area2, error2, resabs2, resasc2) + case default + call dqk41 (f, a1, b1, area1, error1, resabs1, resasc1) + call dqk41 (f, a2, b2, area2, error2, resabs2, resasc2) + end select + area12 = area1 + area2 + error12 = error1 + error2 + errsum = errsum + error12 - e_i + area = area + area12 - r_i + if (resasc1 /= error1 .and. resasc2 /= error2) then + delta = r_i - area12 + if (abs(delta) <= 1.0e-5_default * abs (area12) .and. & + error12 >= 0.99_default * e_i) then + roundoff_type1 = roundoff_type1 + 1 + end if + if (iteration >= 10 .and. error12 > e_i) then + roundoff_type2 = roundoff_type2 + 1 + end if + end if + tolerance_g = max (epsabs, epsrel * abs(area)) + if (errsum > tolerance_g) then + if (roundoff_type1 >= 6 .or. roundoff_type2 >= 20) & + error stop ("Gauss_Kronrod: roundoff error prevents tolerance " & + // "from being achieved") + ! Set error flag in the case of bad integrand behavior at a + ! point of the integration range + if (subinterval_too_small (a1, a2, b2)) & + error stop ("Gauss_Kronrod: bad integrand behavior found in " & + // "integration interval") + end if + call work%update (a1, b1, area1, error1, a2, b2, area2, error2) + if (errsum <= tolerance_g) exit ITERATION_LOOP + end do ITERATION_LOOP + result = sum (work%rlist (1:work%size)) + abserr = errsum + if (errsum > tolerance_g) & + error stop ("Gauss_Kronrod: could not integrate function") + contains + function subinterval_too_small (a_1, a_2, b_2) result (flag) + real(default), intent(in) :: a_1, a_2, b_2 + logical :: flag + real(default) :: tmp + tmp = (1._default + 100._default * dbl_prec) * (abs(a_2) + & + 1000._default * dbl_min) + flag = abs(a_1) <= tmp .and. abs(b_2) <= tmp + end function subinterval_too_small + end subroutine gauss_kronrod + +@ %def gauss_kronrod +@ \subsection{Suppression of numerical noise} <>= public :: pacify <>= interface pacify module procedure pacify_real_default module procedure pacify_complex_default end interface pacify <>= elemental module subroutine pacify_real_default (x, tolerance) real(default), intent(inout) :: x real(default), intent(in) :: tolerance end subroutine pacify_real_default elemental module subroutine pacify_complex_default (x, tolerance) complex(default), intent(inout) :: x real(default), intent(in) :: tolerance end subroutine pacify_complex_default <>= elemental module subroutine pacify_real_default (x, tolerance) real(default), intent(inout) :: x real(default), intent(in) :: tolerance if (abs (x) < tolerance) x = 0._default end subroutine pacify_real_default elemental module subroutine pacify_complex_default (x, tolerance) complex(default), intent(inout) :: x real(default), intent(in) :: tolerance if (abs (real (x)) < tolerance) & x = cmplx (0._default, aimag (x), kind=default) if (abs (aimag (x)) < tolerance) & x = cmplx (real (x), 0._default, kind=default) end subroutine pacify_complex_default @ %def pacify @ +<<[[numeric_utils_ut.f90]]>>= +<> + +module numeric_utils_ut + use unit_tests + use numeric_utils_uti + +<> + +<> + + contains + +<> + +end module numeric_utils_ut +@ %def numeric_utils_ut +@ +<<[[numeric_utils_uti.f90]]>>= +<> + +module numeric_utils_uti + +<> + use constants, only: one, PI + use numeric_utils + +<> + +<> + + contains + +<> + +end module numeric_utils_uti +@ %def numeric_utils_uti +@ +<>= + public :: numeric_utils_test +<>= + subroutine numeric_utils_test (u, results) + integer, intent(in) :: u + type(test_results_t), intent(inout) :: results + <> + end subroutine numeric_utils_test + +@ %def numeric_utils_test +@ Provide testing for routines in the [[numeric_utils]] module. +<>= +call test (numeric_utils_1, "numeric_utils_1", & + "check interface and implementation", & + u, results) +<>= + public :: numeric_utils_1 +<>= + subroutine numeric_utils_1 (u) + integer, intent(in) :: u + real(default) :: int, intabs, err, errabs + real(default) :: a, b, c + a = 0._default + b = 1._default + c = Pi + + write (u, "(A)") "* Test output: Numeric utils" + write (u, "(A)") "* Purpose: test numeric routines" + write (u, "(A)") + + write (u, "(A)") "* 41-point Gauss-Kronrod integration" + write (u, "(A)") + + call dqk41 (f_x, a, b, int, intabs, err, errabs) + write (u, "(1x,A,F9.6)") " Integral (x,[0,1]) = ", & + int + call dqk41 (f_x2, a, b, int, intabs, err, errabs) + write (u, "(1x,A,F9.6)") " Integral (x**2,[0,1]) = ", & + int + call dqk41 (sinx, a, c, int, intabs, err, errabs) + write (u, "(1x,A,F9.6)") " Integral (sin(x),[0,Pi]) = ", & + int + + contains + + function f_x (x) result (f) + real(default), intent(in) :: x + real(default) :: f + f = x + end function f_x + function f_x2 (x) result (f) + real(default), intent(in) :: x + real(default) :: f + f = x**2 + end function f_x2 + function sinx (x) result (f) + real(default), intent(in) :: x + real(default) :: f + f = sin(x) + end function sinx + end subroutine numeric_utils_1 + +@ %def numeric_utils_1 +@ +<>= +call test (numeric_utils_2, "numeric_utils_2", & + "check adaptive integration", & + u, results) +<>= + public :: numeric_utils_2 +<>= + subroutine numeric_utils_2 (u) + integer, intent(in) :: u + real(default) :: result, abserr + real(default), parameter :: epsabs = 0.001_default, & + epsrel = 0.001_default + real(default), parameter :: a = 0._default, b = 1._default, & + z = 0.1_default + integer, parameter :: limit = 10000 + + write (u, "(A)") "* Test output: Numeric utils" + write (u, "(A)") "* Purpose: test adaptive Gauss-Kronrod 41" + write (u, "(A)") + + write (u, "(A)") "* 41-point Gauss-Kronrod integration" + write (u, "(A)") + + call gauss_kronrod (GAUSS_KRONROD_41, f1_x, a, b, limit, result, & + abserr, epsabs, epsrel) + write (u, "(1x,A,F9.6)") " Integral (f1_x,[0,1]) = ", & + result + call gauss_kronrod (GAUSS_KRONROD_41, f2_x, a, b, limit, result, & + abserr, epsabs, epsrel) + write (u, "(1x,A,F9.6)") " Integral (f2_x,[0,1]) = ", & + result + + contains + + function f1_x (x) result (f) + real(default), intent(in) :: x + real(default) :: f + f = log(one - z/(one + (-one + z)*x)) + end function f1_x + function f2_x (x) result (f) + real(default), intent(in) :: x + real(default) :: f + f = log(one - z/(z + x)) + end function f2_x + end subroutine numeric_utils_2 + +@ %def numeric_utils_2 +@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Binary Tree} <<[[binary_tree.f90]]>>= <> module binary_tree <> <> <> interface <> end interface contains <> end module binary_tree @ %def binary_tree @ <<[[binary_tree_sub.f90]]>>= <> submodule (binary_tree) binary_tree_s use io_units implicit none contains <> end submodule binary_tree_s @ %def binary_tree_s @ <>= public :: binary_tree_iterator_t <>= type :: binary_tree_iterator_t integer, dimension(:), allocatable :: key integer :: current !! current \in {1, N}. contains <> end type binary_tree_iterator_t @ %def binary_tree_iterator_t @ <>= type :: binary_tree_node_t integer :: height = 0 type(binary_tree_node_t), pointer :: left => null () type(binary_tree_node_t), pointer :: right => null () !! integer :: key = 0 class(*), pointer :: obj => null () contains <> end type binary_tree_node_t @ %def binary_tree_node_t @ <>= public :: binary_tree_t <>= type :: binary_tree_t integer :: n_elements = 0 type(binary_tree_node_t), pointer :: root => null () contains <> end type binary_tree_t @ %def binary_tree_t @ <>= procedure :: init => binary_tree_iterator_init <>= module subroutine binary_tree_iterator_init (iterator, btree) class(binary_tree_iterator_t), intent(inout) :: iterator type(binary_tree_t), target :: btree end subroutine binary_tree_iterator_init <>= !! We store all keys of the binary tree in an index array. !! Flatten the tree O(log n), each access is then O(1). !! However, accessing the corresponding object costs one O(log n). module subroutine binary_tree_iterator_init (iterator, btree) class(binary_tree_iterator_t), intent(inout) :: iterator type(binary_tree_t), target :: btree type(binary_tree_node_t), pointer :: node integer :: idx iterator%current = 1 allocate (iterator%key(btree%get_n_elements ()), source = 0) if (.not. btree%get_n_elements () > 0) return idx = 1; call fill_key (idx, iterator%key, btree%root) contains recursive subroutine fill_key (idx, key, node) integer, intent(inout) :: idx integer, dimension(:), intent(inout) :: key type(binary_tree_node_t), pointer :: node if (associated (node%left)) & call fill_key (idx, key, node%left) key(idx) = node%key idx = idx + 1 if (associated (node%right)) & call fill_key (idx, key, node%right) end subroutine fill_key end subroutine binary_tree_iterator_init @ %def binary_tree_iterator_init @ <>= procedure :: is_iterable => binary_tree_iterator_is_iterable <>= module function binary_tree_iterator_is_iterable (iterator) result (flag) class(binary_tree_iterator_t), intent(in) :: iterator logical :: flag end function binary_tree_iterator_is_iterable <>= module function binary_tree_iterator_is_iterable (iterator) result (flag) class(binary_tree_iterator_t), intent(in) :: iterator logical :: flag flag = iterator%current <= size (iterator%key) end function binary_tree_iterator_is_iterable @ %def binary_tree_iterator_is_handle @ <>= procedure :: next => binary_tree_iterator_next <>= module subroutine binary_tree_iterator_next (iterator, key) class(binary_tree_iterator_t), intent(inout) :: iterator integer, intent(out) :: key end subroutine binary_tree_iterator_next <>= module subroutine binary_tree_iterator_next (iterator, key) class(binary_tree_iterator_t), intent(inout) :: iterator integer, intent(out) :: key if (.not. iterator%is_iterable ()) then key = 0 else key = iterator%key(iterator%current) iterator%current = iterator%current + 1 end if end subroutine binary_tree_iterator_next @ %def binary_tree_iterator_next @ <>= procedure :: init => binary_tree_node_init <>= module subroutine binary_tree_node_init (btree_node, key, obj) class(binary_tree_node_t), intent(inout) :: btree_node integer, intent(in) :: key class(*), pointer :: obj end subroutine binary_tree_node_init <>= module subroutine binary_tree_node_init (btree_node, key, obj) class(binary_tree_node_t), intent(inout) :: btree_node integer, intent(in) :: key class(*), pointer :: obj btree_node%height = 1 btree_node%left => null () btree_node%right => null () btree_node%key = key btree_node%obj => obj end subroutine binary_tree_node_init @ %def binary_tree_node_init @ <>= procedure :: write => binary_tree_node_write <>= recursive module subroutine binary_tree_node_write & (btree_node, unit, level, mode) class(binary_tree_node_t), intent(in) :: btree_node integer, intent(in) :: unit integer, intent(in) :: level character(len=*), intent(in) :: mode end subroutine binary_tree_node_write <>= recursive module subroutine binary_tree_node_write & (btree_node, unit, level, mode) class(binary_tree_node_t), intent(in) :: btree_node integer, intent(in) :: unit integer, intent(in) :: level character(len=*), intent(in) :: mode character(len=24) :: fmt if (level > 0) then write (fmt, "(A,I3,A)") "(", 3 * level, "X,A,1X,I3,1X,I3,A)" else fmt = "(A,1X,I3,1X,I3,1X)" end if write (unit, fmt) mode, btree_node%key, btree_node%height ! write (unit, fmt) btree_node%key, btree_node%get_balance () if (associated (btree_node%right)) & call btree_node%right%write (unit, level = level + 1, mode = ">") if (associated (btree_node%left)) & call btree_node%left%write (unit, level = level + 1, mode = "<") end subroutine binary_tree_node_write @ %def binary_tree_node_write @ <>= procedure :: get_balance => binary_tree_node_get_balance <>= module function binary_tree_node_get_balance (btree_node) result (balance) class(binary_tree_node_t), intent(in) :: btree_node integer :: balance end function binary_tree_node_get_balance <>= module function binary_tree_node_get_balance (btree_node) result (balance) class(binary_tree_node_t), intent(in) :: btree_node integer :: balance integer :: leftHeight, rightHeight leftHeight = 0 rightHeight = 0 if (associated (btree_node%left)) leftHeight = btree_node%left%height if (associated (btree_node%right)) rightHeight = btree_node%right%height balance = leftHeight - rightHeight end function binary_tree_node_get_balance @ %def binary_tree_node_get_balance @ <>= procedure :: increment_height => binary_tree_node_increment_height <>= module subroutine binary_tree_node_increment_height (btree_node) class(binary_tree_node_t), intent(inout) :: btree_node end subroutine binary_tree_node_increment_height <>= module subroutine binary_tree_node_increment_height (btree_node) class(binary_tree_node_t), intent(inout) :: btree_node integer :: leftHeight, rightHeight leftHeight = 0 rightHeight = 0 if (associated (btree_node%left)) leftHeight = btree_node%left%height if (associated (btree_node%right)) rightHeight = btree_node%right%height btree_node%height = max (leftHeight, rightHeight) + 1 end subroutine binary_tree_node_increment_height @ %def binary_tree_node_increment_height @ <>= final :: binary_tree_node_final <>= !!! !!! NAG 7 compiler bug with finalizers and unlimited polymorphism !!! module subroutine binary_tree_node_final (btree_node) !!! type(binary_tree_node_t), intent(inout) :: btree_node !!! end subroutine binary_tree_node_final <>= recursive subroutine binary_tree_node_final (btree_node) type(binary_tree_node_t), intent(inout) :: btree_node if (associated (btree_node%left)) deallocate (btree_node%left) if (associated (btree_node%right)) deallocate (btree_node%right) deallocate (btree_node%obj) end subroutine binary_tree_node_final @ %def binary_tree_node_final @ <>= procedure :: write => binary_tree_write <>= module subroutine binary_tree_write (btree, unit) class(binary_tree_t), intent(in) :: btree integer, intent(in), optional :: unit end subroutine binary_tree_write <>= module subroutine binary_tree_write (btree, unit) class(binary_tree_t), intent(in) :: btree integer, intent(in), optional :: unit integer :: u u = given_output_unit(unit=unit) write (u, "(A,1X,I3)") "Number of elements", btree%n_elements if (associated (btree%root)) then call btree%root%write (u, level = 0, mode = "*") else write (u, "(A)") "Binary tree is empty." end if end subroutine binary_tree_write @ %def binary_tree_write @ <>= final :: binary_tree_final <>= !!! !!! NAG 7 compiler bug with finalizers and unlimited polymorphism !!! module subroutine binary_tree_final (btree) !!! type(binary_tree_t), intent(inout) :: btree !!! end subroutine binary_tree_final <>= subroutine binary_tree_final (btree) type(binary_tree_t), intent(inout) :: btree btree%n_elements = 0 if (associated (btree%root)) then deallocate (btree%root) end if end subroutine binary_tree_final @ %def binary_tree_final @ <>= procedure :: clear => binary_tree_clear <>= module subroutine binary_tree_clear (btree) class(binary_tree_t), intent(inout) :: btree end subroutine binary_tree_clear <>= module subroutine binary_tree_clear (btree) class(binary_tree_t), intent(inout) :: btree call binary_tree_final (btree) end subroutine binary_tree_clear @ %def binary_tree_clear @ <>= procedure :: get_n_elements => binary_tree_get_n_elements <>= module function binary_tree_get_n_elements (btree) result (n) class(binary_tree_t), intent(in) :: btree integer :: n end function binary_tree_get_n_elements <>= module function binary_tree_get_n_elements (btree) result (n) class(binary_tree_t), intent(in) :: btree integer :: n n = btree%n_elements end function binary_tree_get_n_elements @ %def binary_tree_get_n_elements @ <>= procedure :: insert => binary_tree_insert <>= module subroutine binary_tree_insert (btree, key, obj) class(binary_tree_t), intent(inout) :: btree integer, intent(in) :: key class(*), pointer, intent(in) :: obj end subroutine binary_tree_insert <>= module subroutine binary_tree_insert (btree, key, obj) class(binary_tree_t), intent(inout) :: btree integer, intent(in) :: key class(*), pointer, intent(in) :: obj type(binary_tree_node_t), pointer :: node allocate (node) call node%init (key, obj) btree%n_elements = btree%n_elements + 1 if (.not. associated (btree%root)) then btree%root => node else call btree%insert_node (btree%root, node) end if end subroutine binary_tree_insert @ %def binary_tree_import @ <>= procedure, private :: insert_node => binary_tree_insert_node <>= recursive module subroutine binary_tree_insert_node (btree, parent, node) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), intent(inout), pointer :: parent type(binary_tree_node_t), intent(in), pointer :: node end subroutine binary_tree_insert_node <>= recursive module subroutine binary_tree_insert_node (btree, parent, node) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), intent(inout), pointer :: parent type(binary_tree_node_t), intent(in), pointer :: node !! Choose left or right, if associated descend recursively into subtree, !! else insert node. if (node%key > parent%key) then if (associated (parent%right)) then call btree%insert_node (parent%right, node) else parent%right => node end if else if (node%key < parent%key) then if (associated (parent%left)) then call btree%insert_node (parent%left, node) else parent%left => node end if else write (*, "(A,1X,I0)") "Error: MUST not insert duplicate key", node%key stop 1 end if call parent%increment_height () call btree%balance (parent, node%key) end subroutine binary_tree_insert_node @ %def binary_tree_insert_node @ <>= procedure, private :: balance => binary_tree_balance <>= module subroutine binary_tree_balance (btree, subtree, key) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), intent(inout), pointer :: subtree integer, intent(in) :: key end subroutine binary_tree_balance <>= !! Subtree: root of subtree (which is unbalance, refer to A in diagrams.) module subroutine binary_tree_balance (btree, subtree, key) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), intent(inout), pointer :: subtree integer, intent(in) :: key type(binary_tree_node_t), pointer :: node, newNode integer :: balance balance = subtree%get_balance () node => subtree newNode => null () !! balance := h_left - h_right. !! Proof: balance > 0 => too many elements on the left side of the subtree. !! Proof: balance < 0 => too many elements on the right side of the subtree. if (balance > 1) then !! => left-side of subtree !! A3(2) B2(1) !! / / \ !! B2(1) C1(0) A1(0) !! / !! C1(0) !! !! A3(3) A1(2) C2(1) !! / / / \ !! B1(1) LEFT C2(1) RIGHT B1(0) A3(0) !! \ / !! C2(0) B1(0) if (subtree%left%key > key) then !! rotate right call btree%rotate_right (node, newNode) else !! subtree%left%key < key, rotate left, then right. call btree%rotate_left (node%left, newNode) node%left => newNode call btree%rotate_right (node, newNode) end if else if (balance < -1) then !! => right-side of subtree !! A0(2) B1(1) !! \ / \ !! B1(1) A1(0) C3(0) !! \ !! C3(0)* !! !! A1(2) A1(2) C2(1) !! \ \ / \ !! B3(1) RIGHT C2(1) LEFT A1(0) B3(0) !! / \ !! C2(0) B3(0) if (subtree%right%key < key) then !! rotate left call btree%rotate_left (node, newNode) else !! subtree%right%key > key, rotate right, then left. call btree%rotate_right (node%right, newNode) node%right => newNode call btree%rotate_left (node, newNode) end if end if if (associated (newNode)) subtree => newNode end subroutine binary_tree_balance @ %def binary_tree_balance @ <>= procedure :: search => binary_tree_search <>= module subroutine binary_tree_search (btree, key, obj) class(binary_tree_t), intent(in) :: btree integer, intent(in) :: key class(*), pointer, intent(out) :: obj end subroutine binary_tree_search <>= module subroutine binary_tree_search (btree, key, obj) class(binary_tree_t), intent(in) :: btree integer, intent(in) :: key class(*), pointer, intent(out) :: obj type(binary_tree_node_t), pointer :: current current => btree%root obj => null () if (.not. associated (current)) return do while (current%key /= key) if (current%key > key) then current => current%left else current => current%right end if if (.not. associated (current)) then !! Key not found. exit end if end do if (associated (current)) obj => current%obj end subroutine binary_tree_search @ %def binary_tree_search @ <>= procedure :: has_key => binary_tree_has_key <>= module function binary_tree_has_key (btree, key) result (flag) class(binary_tree_t), intent(in) :: btree integer, intent(in) :: key logical :: flag end function binary_tree_has_key <>= module function binary_tree_has_key (btree, key) result (flag) class(binary_tree_t), intent(in) :: btree integer, intent(in) :: key logical :: flag type(binary_tree_node_t), pointer :: current current => btree%root flag = .false. if (.not. associated (current)) return do while (current%key /= key) if (current%key > key) then current => current%left else current => current%right end if if (.not. associated (current)) then !! Key not found. return end if end do flag = .true. end function binary_tree_has_key @ %def binary_tree_has_key @ <>= procedure, private :: rotate_right => binary_tree_rotate_right <>= module subroutine binary_tree_rotate_right (btree, root, new_root) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), pointer, intent(inout) :: root type(binary_tree_node_t), pointer, intent(out) :: new_root end subroutine binary_tree_rotate_right <>= !! A Move B to A. !! / \ !! B E 1. Split B from A%left. !! / \ 2. Temporarily pointer to D. !! C D 3. Replace pointer to D by pointer to A - E. !! 4. Set temporary pointer to D to A%left. !! !! 1.+2. B T => D A !! / \ !! C E !! !! 3. B T => D !! / \ !! C A !! \ !! E !! !! 4. B !! / \ !! C A !! / \ !! D E !! !! \param[inout] root Root/parent root (A). !! \param[out] new_root New root/parent root (B). module subroutine binary_tree_rotate_right (btree, root, new_root) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), pointer, intent(inout) :: root type(binary_tree_node_t), pointer, intent(out) :: new_root type(binary_tree_node_t), pointer :: tmp new_root => root%left tmp => new_root%right new_root%right => root root%left => tmp call root%increment_height () call new_root%increment_height () end subroutine binary_tree_rotate_right @ %def binary_tree_rotate_right @ <>= procedure, private :: rotate_left => binary_tree_rotate_left <>= module subroutine binary_tree_rotate_left (btree, root, new_root) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), pointer, intent(inout) :: root type(binary_tree_node_t), pointer, intent(out) :: new_root end subroutine binary_tree_rotate_left <>= !! A Move B to A. !! / \ !! E B 1. Split B from A%left. !! / \ 2. Temporarily pointer to C. !! C D 3. Replace pointer to C by pointer to A - E. !! 4. Set temporary pointer to C to A%right. !! !! 1.+2. B T => C A !! \ / !! D E !! !! 3. B T => C !! / \ !! A D !! / !! E !! !! 4. B !! / \ !! A D !! / \ !! E C module subroutine binary_tree_rotate_left (btree, root, new_root) class(binary_tree_t), intent(in) :: btree type(binary_tree_node_t), pointer, intent(inout) :: root type(binary_tree_node_t), pointer, intent(out) :: new_root type(binary_tree_node_t), pointer :: tmp new_root => root%right tmp => new_root%left new_root%left => root root%right => tmp call root%increment_height () call new_root%increment_height () end subroutine binary_tree_rotate_left @ %def binary_tree_rotate_left @ \subsection{Unit tests} \label{sec:unit-tests} <<[[binary_tree_ut.f90]]>>= <> module binary_tree_ut use unit_tests use binary_tree_uti <> <> contains <> end module binary_tree_ut @ %def binary_tree_ut @ <<[[binary_tree_uti.f90]]>>= <> module binary_tree_uti use binary_tree <> type :: btree_obj_t integer :: i = 0 end type btree_obj_t <> contains <> end module binary_tree_uti @ %def binary_tree_uti @ <>= -public :: binary_tree_test + public :: binary_tree_test <>= -subroutine binary_tree_test (u, results) - integer, intent(in) :: u - type(test_results_t), intent(inout) :: results - <> -end subroutine binary_tree_test + subroutine binary_tree_test (u, results) + integer, intent(in) :: u + type(test_results_t), intent(inout) :: results + <> + end subroutine binary_tree_test @ %def binary_tree_test @ Provide testing for interface stability and correct implementation for the binary tree and its iterator. <>= call test (binary_tree_1, "binary_tree_1", & "check interface and implementation", & u, results) <>= public :: binary_tree_1 <>= -subroutine binary_tree_1 (u) - integer, intent(in) :: u - integer, dimension(10) :: ndx = [1, 2, 5, 7, 19, 23, 97, -1, -6, 0] - class(*), pointer :: obj - type(binary_tree_t) :: btree - type(binary_tree_iterator_t) :: iterator - integer :: i, key - write (u, "(A)") "* Test outout: Binary tree" - write (u, "(A)") "* Purpose: test interface and implementation of binary tree " // & - "and its iterator using polymorph objects." - write (u, "(A)") - - write (u, "(A)") "* Insert fixed number of object into tree..." - do i = 1, size (ndx) - call allocate_obj (i, obj) - call btree%insert (ndx(i), obj) - end do + subroutine binary_tree_1 (u) + integer, intent(in) :: u + integer, dimension(10) :: ndx = [1, 2, 5, 7, 19, 23, 97, -1, -6, 0] + class(*), pointer :: obj + type(binary_tree_t) :: btree + type(binary_tree_iterator_t) :: iterator + integer :: i, key + write (u, "(A)") "* Test output: Binary tree" + write (u, "(A)") "* Purpose: test interface and implementation of binary tree " // & + "and its iterator using polymorph objects." + write (u, "(A)") + + write (u, "(A)") "* Insert fixed number of objects into tree..." + do i = 1, size (ndx) + call allocate_obj (i, obj) + call btree%insert (ndx(i), obj) + end do - write (u, "(A)") "* Search for all added objects in tree..." - do i = size (ndx), 1, -1 - write (u, "(A,1X,I3,1X,L1)") "- Has key", ndx(i), btree%has_key (ndx(i)) - call btree%search (ndx(i), obj) - select type (obj) - type is (btree_obj_t) - write (u, "(2(A,1X,I3,1X))") "- NDX", ndx(i), "OBJ", obj%i - end select - end do + write (u, "(A)") "* Search for all added objects in tree..." + do i = size (ndx), 1, -1 + write (u, "(A,1X,I3,1X,L1)") "- Has key", ndx(i), btree%has_key (ndx(i)) + call btree%search (ndx(i), obj) + select type (obj) + type is (btree_obj_t) + write (u, "(2(A,1X,I3,1X))") "- NDX", ndx(i), "OBJ", obj%i + end select + end do - write (u, "(A)") "* Output binary tree in preorder..." - call btree%write (u) + write (u, "(A)") "* Output binary tree in preorder..." + call btree%write (u) - write (u, "(A)") "* Clear binary tree..." - call btree%clear () - call btree%write (u) - - write (u, "(A)") "* Insert fixed number of object into tree (reversed order)..." - do i = size (ndx), 1, -1 - call allocate_obj (i, obj) - call btree%insert (ndx(i), obj) - end do + write (u, "(A)") "* Clear binary tree..." + call btree%clear () + call btree%write (u) + + write (u, "(A)") "* Insert fixed number of object into tree (reversed order)..." + do i = size (ndx), 1, -1 + call allocate_obj (i, obj) + call btree%insert (ndx(i), obj) + end do - write (u, "(A)") "* Iterate over binary tree..." - call iterator%init (btree) - do while (iterator%is_iterable ()) - call iterator%next (key) - call btree%search (key, obj) - select type (obj) - type is (btree_obj_t) - write (u, "(2(A,1X,I3,1X))") "- KEY", key, "OBJ", obj%i - end select - end do + write (u, "(A)") "* Iterate over binary tree..." + call iterator%init (btree) + do while (iterator%is_iterable ()) + call iterator%next (key) + call btree%search (key, obj) + select type (obj) + type is (btree_obj_t) + write (u, "(2(A,1X,I3,1X))") "- KEY", key, "OBJ", obj%i + end select + end do - write (u, "(A)") "* Search for a non-existing key..." - write (u, "(A,1X,I3,1X,L1)") "- Has key", 123, btree%has_key (123) - call btree%search (123, obj) - write (u, "(A,1X,L1)") "- Object found", associated (obj) + write (u, "(A)") "* Search for a non-existing key..." + write (u, "(A,1X,I3,1X,L1)") "- Has key", 123, btree%has_key (123) + call btree%search (123, obj) + write (u, "(A,1X,L1)") "- Object found", associated (obj) - !! Do not test against a duplicate entry as the it will forcibly stop the program. -contains - subroutine allocate_obj (num, obj) - integer, intent(in) :: num - class(*), pointer, intent(out) :: obj - allocate (btree_obj_t :: obj) - select type (obj) - type is (btree_obj_t) - obj%i = num - end select - end subroutine allocate_obj -end subroutine binary_tree_1 + !! Do not test against a duplicate entry as the it will forcibly stop the program. + contains + subroutine allocate_obj (num, obj) + integer, intent(in) :: num + class(*), pointer, intent(out) :: obj + allocate (btree_obj_t :: obj) + select type (obj) + type is (btree_obj_t) + obj%i = num + end select + end subroutine allocate_obj + end subroutine binary_tree_1 @ %def binary_tree_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Array List} <<[[array_list.f90]]>>= <> module array_list <> <> <> <> <> interface <> end interface end module array_list @ %def array_list @ <<[[array_list_sub.f90]]>>= <> submodule (array_list) array_list_s use, intrinsic :: iso_fortran_env, only: ERROR_UNIT use io_units implicit none contains <> end submodule array_list_s @ %def array_list_s @ <>= integer, parameter :: ARRAY_LIST_START_SIZE = 10 real(default), parameter :: ARRAY_LIST_GROW_FACTOR = 1.5_default, & ARRAY_LIST_SHRINK_THRESHOLD = 0.3_default @ %def array_list_start_size array_list_grow_factor @ %def array_list_shrink_threshold @ <>= public :: array_list_t <>= type :: array_list_t private integer, dimension(:), allocatable :: array !! Track the index to *current* item, to be stored. !! Must fulfill: 0 <= count <= size. integer :: count = 0 !! size \in N. integer :: size = 0 contains <> end type array_list_t @ %def array_list_t @ <>= procedure :: write => array_list_write <>= module subroutine array_list_write (list, unit) class(array_list_t), intent(in) :: list integer, intent(in), optional :: unit end subroutine array_list_write <>= module subroutine array_list_write (list, unit) class(array_list_t), intent(in) :: list integer, intent(in), optional :: unit integer :: u u = ERROR_UNIT; if (present (unit)) u = unit write (u, "(A,2(1X,I3))") "COUNT / SIZE", list%count, list%size write (u, "(999(1X,I4))") list%array end subroutine array_list_write @ %def array_list_write @ <>= procedure :: init => array_list_init <>= module subroutine array_list_init (list) class(array_list_t), intent(out) :: list end subroutine array_list_init <>= module subroutine array_list_init (list) class(array_list_t), intent(out) :: list allocate (list%array(ARRAY_LIST_START_SIZE), source = 0) list%count = 0 list%size = ARRAY_LIST_START_SIZE end subroutine array_list_init @ %def array_list_init @ <>= procedure :: get => array_list_get <>= elemental module function array_list_get (list, index) result (data) class(array_list_t), intent(in) :: list integer, intent(in) :: index integer :: data end function array_list_get <>= elemental module function array_list_get (list, index) result (data) class(array_list_t), intent(in) :: list integer, intent(in) :: index integer :: data if (list%is_index (index)) then data = list%array(index) else data = 0 end if end function array_list_get @ %def array_list_get @ <>= procedure :: get_count => array_list_get_count <>= pure module function array_list_get_count (list) result (count) class(array_list_t), intent(in) :: list integer :: count end function array_list_get_count <>= pure module function array_list_get_count (list) result (count) class(array_list_t), intent(in) :: list integer :: count count = list%count end function array_list_get_count @ %def array_list_get_count @ <>= procedure :: get_size => array_list_get_size <>= pure module function array_list_get_size (list) result (size) class(array_list_t), intent(in) :: list integer :: size end function array_list_get_size <>= pure module function array_list_get_size (list) result (size) class(array_list_t), intent(in) :: list integer :: size size = list%size end function array_list_get_size @ %def array_list_get_size @ <>= procedure :: is_full => array_list_is_full <>= pure module function array_list_is_full (list) result (flag) class(array_list_t), intent(in) :: list logical :: flag end function array_list_is_full <>= pure module function array_list_is_full (list) result (flag) class(array_list_t), intent(in) :: list logical :: flag flag = list%count >= list%size end function array_list_is_full @ %def array_list_is_full @ <>= procedure :: is_empty => array_list_is_empty <>= pure module function array_list_is_empty (list) result (flag) class(array_list_t), intent(in) :: list logical :: flag end function array_list_is_empty <>= pure module function array_list_is_empty (list) result (flag) class(array_list_t), intent(in) :: list logical :: flag flag = .not. list%count > 0 end function array_list_is_empty @ %def array_list_is_empty @ <>= procedure :: is_index => array_list_is_index <>= pure module function array_list_is_index (list, index) result (flag) class(array_list_t), intent(in) :: list integer, intent(in) :: index logical :: flag end function array_list_is_index <>= pure module function array_list_is_index (list, index) result (flag) class(array_list_t), intent(in) :: list integer, intent(in) :: index logical :: flag flag = 0 < index .and. index <= list%count end function array_list_is_index @ %def array_list_is_index @ <>= procedure :: clear => array_list_clear <>= module subroutine array_list_clear (list) class(array_list_t), intent(inout) :: list end subroutine array_list_clear <>= module subroutine array_list_clear (list) class(array_list_t), intent(inout) :: list list%array = 0 list%count = 0 call list%shrink_size () end subroutine array_list_clear @ %def array_list_clear @ <>= procedure :: add => array_list_add <>= module subroutine array_list_add (list, data) class(array_list_t), intent(inout) :: list integer, intent(in) :: data end subroutine array_list_add <>= module subroutine array_list_add (list, data) class(array_list_t), intent(inout) :: list integer, intent(in) :: data list%count = list%count + 1 if (list%is_full ()) then call list%grow_size () end if list%array(list%count) = data end subroutine array_list_add @ %def array_list_add @ <>= procedure :: grow_size => array_list_grow_size <>= module subroutine array_list_grow_size (list) class(array_list_t), intent(inout) :: list end subroutine array_list_grow_size <>= module subroutine array_list_grow_size (list) class(array_list_t), intent(inout) :: list integer, dimension(:), allocatable :: array integer :: new_size if (.not. list%is_full ()) return new_size = int (list%size * ARRAY_LIST_GROW_FACTOR) allocate (array(new_size), source = 0) array(:list%size) = list%array call move_alloc (array, list%array) list%size = size (list%array) end subroutine array_list_grow_size @ %def array_list_grow_size @ <>= procedure :: shrink_size => array_list_shrink_size <>= module subroutine array_list_shrink_size (list) class(array_list_t), intent(inout) :: list integer, dimension(:), allocatable :: array end subroutine array_list_shrink_size <>= module subroutine array_list_shrink_size (list) class(array_list_t), intent(inout) :: list integer, dimension(:), allocatable :: array integer :: new_size !! Apply shrink threshold on count. ! if (.not. list%count > 0) return new_size = max (list%count, ARRAY_LIST_START_SIZE) allocate (array(new_size), source = 0) !! \note We have to circumvent the allocate-on-assignment, !! hence, we explicitly set the array boundaries. array(:list%count) = list%array(:list%count) call move_alloc (array, list%array) list%size = new_size end subroutine array_list_shrink_size @ %def array_list_shrink_size @ <>= procedure :: reverse_order => array_list_reverse_order <>= module subroutine array_list_reverse_order (list) class(array_list_t), intent(inout) :: list end subroutine array_list_reverse_order <>= module subroutine array_list_reverse_order (list) class(array_list_t), intent(inout) :: list list%array(:list%count) = list%array(list%count:1:-1) end subroutine array_list_reverse_order @ %def array_list_reverse_order @ <>= procedure :: sort => array_list_sort <>= pure module subroutine array_list_sort (list) class(array_list_t), intent(inout) :: list end subroutine array_list_sort <>= pure module subroutine array_list_sort (list) class(array_list_t), intent(inout) :: list if (list%is_empty ()) return call quick_sort (list%array(:list%count)) contains pure recursive subroutine quick_sort (array) integer, dimension(:), intent(inout) :: array integer :: pivot, tmp integer :: first, last integer i, j first = 1 last = size(array) pivot = array(int ((first+last) / 2.)) i = first j = last do do while (array(i) < pivot) i = i + 1 end do do while (pivot < array(j)) j = j - 1 end do if (i >= j) exit tmp = array(i) array(i) = array(j) array(j) = tmp i = i + 1 j = j - 1 end do if (first < i - 1) call quick_sort(array(first:i - 1)) if (j + 1 < last) call quick_sort(array(j + 1:last)) end subroutine quick_sort end subroutine array_list_sort @ %def array_list_sort @ <>= procedure :: is_element => array_list_is_element <>= pure module function array_list_is_element (list, data) result (flag) class(array_list_t), intent(in) :: list integer, intent(in) :: data logical :: flag end function array_list_is_element <>= pure module function array_list_is_element (list, data) result (flag) class(array_list_t), intent(in) :: list integer, intent(in) :: data logical :: flag if (list%is_empty ()) then flag = .false. else flag = any (data == list%array) end if end function array_list_is_element @ %def array_list_is_element @ <>= procedure :: find => array_list_find <>= module function array_list_find (list, data) result (index) class(array_list_t), intent(inout) :: list integer, intent(in) :: data integer :: index end function array_list_find <>= module function array_list_find (list, data) result (index) class(array_list_t), intent(inout) :: list integer, intent(in) :: data integer :: index if (list%is_empty () & .or. .not. list%is_element (data)) then index = 0 return end if call list%sort () !! INTENT(INOUT) index = binary_search_leftmost (list%array(:list%count), data) contains pure function binary_search_leftmost (array, data) result (index) integer, dimension(:), intent(in) :: array integer, intent(in) :: data integer :: index integer :: left, right left = 1 right = size (array) do while (left < right) index = floor ((left + right) / 2.) if (array(index) < data) then left = index + 1 else right = index end if end do index = left end function binary_search_leftmost end function array_list_find @ %def array_list_find @ <>= procedure :: add_at => array_list_add_at <>= module subroutine array_list_add_at (list, index, data) class(array_list_t), intent(inout) :: list integer, intent(in) :: index integer, intent(in) :: data end subroutine array_list_add_at <>= module subroutine array_list_add_at (list, index, data) class(array_list_t), intent(inout) :: list integer, intent(in) :: index integer, intent(in) :: data if (.not. list%is_index (index)) return if (list%is_full ()) then call list%grow_size () end if list%array(index + 1:list%count + 1) = list%array(index:list%count) list%array(index) = data list%count = list%count + 1 end subroutine array_list_add_at @ %def array_list_add_at @ <>= procedure :: remove => array_list_remove <>= module function array_list_remove (list) result (data) class(array_list_t), intent(inout) :: list integer :: data end function array_list_remove <>= module function array_list_remove (list) result (data) class(array_list_t), intent(inout) :: list integer :: data if (list%is_empty ()) then data = 0 return end if data = list%get (list%count) list%array(list%count) = 0 list%count = list%count -1 end function array_list_remove @ %def array_list_remove @ <>= procedure :: remove_at => array_list_remove_at <>= module function array_list_remove_at (list, index) result (data) class(array_list_t), intent(inout) :: list integer, intent(in) :: index integer :: data end function array_list_remove_at <>= module function array_list_remove_at (list, index) result (data) class(array_list_t), intent(inout) :: list integer, intent(in) :: index integer :: data if (list%is_empty ()) then data = 0 return end if data = list%get (index) list%array(index:list%count - 1) = list%array(index + 1:list%count) list%array(list%count) = 0 list%count = list%count - 1 end function array_list_remove_at @ %def array_list_remove_at @ \subsection{Unit tests} \label{sec:unit-tests} <<[[array_list_ut.f90]]>>= <> module array_list_ut use unit_tests use array_list_uti <> <> contains <> end module array_list_ut @ %def array_list_ut @ <<[[array_list_uti.f90]]>>= <> module array_list_uti use array_list <> <> contains <> end module array_list_uti @ %def array_list_uti @ <>= public :: array_list_test <>= subroutine array_list_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine array_list_test @ %def array_list_test @ Provide testing for interface stability and correct implementation for the binary tree and its iterator. <>= call test (array_list_1, "array_list_1", & "check interface and implementation", & u, results) <>= public :: array_list_1 <>= subroutine array_list_1 (u) integer, intent(in) :: u type(array_list_t) :: list integer :: ndx, data write (u, "(A)") "* Test output: Array list" write (u, "(A)") "* Purpose: test interface and implementation of array list" write (u, "(A)") write (u, "(A)") "* Init array_list_t ..." call list%init () write (u, "(A)") "* Test adding a single element..." call list%add (1) write (u, "(A)") "* Test removing a single element..." data = list%remove () write (u, "(A)") "* Test growing (unnecessary, so just return)..." call list%grow_size () write (u, "(A)") "* Test adding elements beyond initial capacity..." call test_grow_and_add (list) write (u, "(A)") "* Test adding at specific position..." call list%add_at (10, -1) write (u, "(A)") "* Test removing at specific position..." data = list%remove_at (11) write (u, "(A)") "* Test reverse ordering..." call list%reverse_order () write (u, "(A)") "* Test sorting..." call list%sort () write (u, "(A)") "* Test finding..." ndx = list%find (1) write (u, "(A)") "* Test shrinking..." call list%shrink_size () write (u, "(A)") "* Test get procedures..." call test_get_procedures (list) write (u, "(A)") "* Test clearing list..." call list%clear () write (u, "(A)") "* Test (more complicated) combinations:" write (u, "(A)") "* Test growing (necessary) during adding..." call test_grow_and_add (list) write (u, "(A)") "* Test adding random data and sorting..." call test_sort (list) write (u, "(A)") "* Test finding (before sorted)..." call test_find (list) contains subroutine test_get_procedures (list) type(array_list_t), intent(in) :: list integer :: n logical :: flag n = list%get(1) n = list%get_size () n = list%get_count () flag = list%is_element (1) end subroutine test_get_procedures subroutine test_grow_and_add (list) type(array_list_t), intent(inout) :: list integer :: i do i = 1, 2 * list%get_size () call list%add (i) end do end subroutine test_grow_and_add subroutine test_get (list) class(array_list_t), intent(inout) :: list integer :: i, data do i = list%get_count (), 1, -1 data = list%get (i) if (data == 0) then write (u, "(A,1X,I3)") "INDEX EMPTY", i end if end do end subroutine test_get subroutine test_sort (list) class(array_list_t), intent(inout) :: list call list%add (6) call list%add (2) call list%add (9) call list%add (4) call list%add (8) call list%add (7) call list%sort () end subroutine test_sort subroutine test_find (list) class(array_list_t), intent(inout) :: list write (u, "(A,1X,I3)") " 6 INDEX", list%find (6) write (u, "(A,1X,I3)") "-1 INDEX", list%find (-1) write (u, "(A,1X,I3)") " 3 INDEX", list%find (3) write (u, "(A,1X,I3)") "26 INDEX", list%find (26) call list%write (u) end subroutine test_find end subroutine array_list_1 @ %def array_list_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Queue} <<[[queue.f90]]>>= <> module queue <> <> <> <> interface <> end interface end module queue @ %def queue @ <<[[queue_sub.f90]]>>= <> submodule (queue) queue_s use, intrinsic :: iso_fortran_env, only: ERROR_UNIT implicit none contains <> end submodule queue_s @ %def queue_s @ <>= integer, parameter :: QUEUE_SIZE = 10, & QUEUE_START = 0, & QUEUE_END = QUEUE_SIZE @ %def queue_size queue_start queue_end @ <>= public :: queue_t <>= type :: queue_t private integer, dimension(QUEUE_SIZE) :: item integer :: front = 0 integer :: rear = 0 contains <> end type queue_t @ %def queue_t @ <>= procedure :: is_full => queue_is_full <>= elemental module function queue_is_full (queue) result (flag) class(queue_t), intent(in) :: queue logical :: flag end function queue_is_full <>= elemental module function queue_is_full (queue) result (flag) class(queue_t), intent(in) :: queue logical :: flag flag = queue%front == 1 .and. queue%rear == QUEUE_END end function queue_is_full @ %def queue_is_full @ <>= procedure :: is_empty => queue_is_empty <>= elemental module function queue_is_empty (queue) result (flag) class(queue_t), intent(in) :: queue logical :: flag end function queue_is_empty <>= elemental module function queue_is_empty (queue) result (flag) class(queue_t), intent(in) :: queue logical :: flag flag = queue%front == QUEUE_START end function queue_is_empty @ %def queue_is_empty @ <>= procedure :: enqueue => queue_enqueue <>= module subroutine queue_enqueue (queue, item) class(queue_t), intent(inout) :: queue integer, intent(in) :: item end subroutine queue_enqueue <>= module subroutine queue_enqueue (queue, item) class(queue_t), intent(inout) :: queue integer, intent(in) :: item if (queue%is_full ()) then !! Do something. else if (queue%front == QUEUE_START) queue%front = 1 queue%rear = queue%rear + 1 queue%item(queue%rear) = item end if end subroutine queue_enqueue @ %def queue_enqueue @ <>= procedure :: dequeue => queue_dequeue <>= module function queue_dequeue (queue) result (item) class(queue_t), intent(inout) :: queue integer :: item end function queue_dequeue <>= module function queue_dequeue (queue) result (item) class(queue_t), intent(inout) :: queue integer :: item if (queue%is_empty ()) then item = 0 else item = queue%item(queue%front) if (queue%front >= queue%rear) then queue%front = QUEUE_START queue%rear = QUEUE_START !! Q has only one element, !! so we reset the queue after deleting it. else queue%front = queue%front + 1 end if end if end function queue_dequeue @ %def queue_dequeue @ <>= procedure :: peek => queue_peek <>= module function queue_peek (queue) result (item) class(queue_t), intent(in) :: queue integer :: item end function queue_peek <>= module function queue_peek (queue) result (item) class(queue_t), intent(in) :: queue integer :: item if (queue%is_empty ()) then item = 0 else item = queue%item(queue%front) end if end function queue_peek @ %def queue_peek @ <>= procedure :: write => queue_write <>= module subroutine queue_write (queue, unit) class(queue_t), intent(in) :: queue integer, intent(in), optional :: unit end subroutine queue_write <>= module subroutine queue_write (queue, unit) class(queue_t), intent(in) :: queue integer, intent(in), optional :: unit integer :: u, i u = ERROR_UNIT; if (present (unit)) u = unit if (queue%is_empty ()) then write (u, *) "Empty Queue." else write (u, *) "Front ->", queue%front write (u, *) "Items ->" do i = 1, queue%rear write (u, *) queue%item(i) end do write (u, *) "Rear ->", queue%rear end if end subroutine queue_write @ %def queue_write @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Iterator} <<[[iterator.f90]]>>= <> module iterator <> <> <> interface <> end interface end module iterator @ %def iterator @ <<[[iterator_sub.f90]]>>= <> submodule (iterator) iterator_s use, intrinsic :: iso_fortran_env, only: ERROR_UNIT implicit none contains <> end submodule iterator_s @ %def iterator_s @ <>= public :: iterator_t <>= !! Forward type :: iterator_t integer :: current = 0 integer :: begin = 0 integer :: end = 0 integer :: step = 1 contains <> end type iterator_t @ %def iterator_t @ <>= procedure :: write => iterator_write <>= module subroutine iterator_write (iter, unit) class(iterator_t), intent(in) :: iter integer, intent(in), optional :: unit end subroutine iterator_write <>= module subroutine iterator_write (iter, unit) class(iterator_t), intent(in) :: iter integer, intent(in), optional :: unit integer :: u u = ERROR_UNIT; if (present (unit)) u = unit write (u, "(3(A,1X,I3,1X))") "CURRENT", iter%current, & "BEGIN", iter%begin, "END", iter%end flush (u) end subroutine iterator_write @ %def iterator_write @ <>= procedure :: init => iterator_init <>= module subroutine iterator_init (iter, begin, end, step) class(iterator_t), intent(inout) :: iter integer, intent(in) :: begin integer, intent(in) :: end integer, intent(in), optional :: step end subroutine iterator_init <>= !! Proof: step > 0, begin < end. !! Proof: step < 0, begin > end. !! Proof: step /= 0. module subroutine iterator_init (iter, begin, end, step) class(iterator_t), intent(inout) :: iter integer, intent(in) :: begin integer, intent(in) :: end integer, intent(in), optional :: step iter%begin = begin iter%end = end iter%step = 1; if (present (step)) iter%step = step if (abs (iter%step) > 0) then iter%current = iter%begin else write (ERROR_UNIT, "(A)") "ERROR: Step size MUST be unequal to zero." stop 1 end if end subroutine iterator_init @ %def iterator_init @ <>= procedure :: at_begin => iterator_at_begin <>= pure module function iterator_at_begin (iter) result (flag) class(iterator_t), intent(in) :: iter logical :: flag end function iterator_at_begin <>= pure module function iterator_at_begin (iter) result (flag) class(iterator_t), intent(in) :: iter logical :: flag flag = iter%current == iter%begin end function iterator_at_begin @ %def iterator_at_begin @ <>= procedure :: at_end => iterator_at_end <>= pure module function iterator_at_end (iter) result (flag) class(iterator_t), intent(in) :: iter logical :: flag end function iterator_at_end <>= pure module function iterator_at_end (iter) result (flag) class(iterator_t), intent(in) :: iter logical :: flag flag = iter%current == iter%end end function iterator_at_end @ %def iterator_at_end @ <>= procedure :: is_iterable => iterator_is_iterable <>= pure module function iterator_is_iterable (iter) result (flag) class(iterator_t), intent(in) :: iter logical :: flag end function iterator_is_iterable <>= !! Proof: begin < current < end pure module function iterator_is_iterable (iter) result (flag) class(iterator_t), intent(in) :: iter logical :: flag if (iter%step > 0) then flag = iter%current <= iter%end else if (iter%step < 0) then flag = iter%current >= iter%end else flag = .false. end if end function iterator_is_iterable @ %def iterator_is_iterable @ <>= procedure :: next_step => iterator_next_step <>= module subroutine iterator_next_step (iter) class(iterator_t), intent(inout) :: iter end subroutine iterator_next_step <>= module subroutine iterator_next_step (iter) class(iterator_t), intent(inout) :: iter if (.not. iter%is_iterable ()) return iter%current = iter%current + iter%step end subroutine iterator_next_step @ %def iterator_next_step @ <>= procedure :: next => iterator_next <>= module function iterator_next (iter) result (ndx) class(iterator_t), intent(inout) :: iter integer :: ndx end function iterator_next <>= !! Proof: begin <= current <= end. !! However, after applying the step, this does not need to be true.. module function iterator_next (iter) result (ndx) class(iterator_t), intent(inout) :: iter integer :: ndx if (.not. iter%is_iterable ()) then ndx = 0 return end if ndx = iter%current iter%current = iter%current + iter%step end function iterator_next @ %def iterator_next @ <>= procedure :: get_current => iterator_get_current <>= pure module function iterator_get_current (iter) result (ndx) class(iterator_t), intent(in) :: iter integer :: ndx end function iterator_get_current <>= pure module function iterator_get_current (iter) result (ndx) class(iterator_t), intent(in) :: iter integer :: ndx if (.not. iter%is_iterable ()) then ndx = 0 return end if ndx = iter%current end function iterator_get_current @ %def iterator_get_current @ \subsection{Unit tests} \label{sec:unit-tests} <<[[iterator_ut.f90]]>>= <> module iterator_ut use unit_tests use iterator_uti <> <> contains <> end module iterator_ut @ %def iterator_ut @ <<[[iterator_uti.f90]]>>= <> module iterator_uti use iterator <> <> contains <> end module iterator_uti @ %def iterator_uti @ <>= public :: iterator_test <>= subroutine iterator_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine iterator_test @ %def iterator_test @ Provide testing for interface stability and correct implementation for the forward integer iterator. <>= call test (iterator_1, "iterator_1", & "check interface and implementation", & u, results) <>= public :: iterator_1 <>= subroutine iterator_1 (u) integer, intent(in) :: u type(iterator_t) :: iter write (u, "(A)") "* Test output: iterator_1" write (u, "(A)") "* Purpose: test interface and implementation of the forward integer iterator" write (u, "(A)") call iter%init (1, 10) call iter%write (u) do while (iter%is_iterable ()) write (u, "(A,1X,I3)") "NDX", iter%next () end do call iter%init (10, 1, -1) call iter%write (u) do while (iter%is_iterable ()) write (u, "(A,1X,I3)") "NDX", iter%next () end do write (u, "(A,1X,I3)") "INVALID NDX", iter%next () call iter%init (1, 10) call iter%write (u) do while (iter%is_iterable ()) call iter%next_step () write (u, "(A)") "STEP." end do end subroutine iterator_1 @ Index: trunk/src/utilities/Makefile.am =================================================================== --- trunk/src/utilities/Makefile.am (revision 8815) +++ trunk/src/utilities/Makefile.am (revision 8816) @@ -1,226 +1,227 @@ ## Makefile.am -- Makefile for WHIZARD ## ## Process this file with automake to produce Makefile.in # # Copyright (C) 1999-2022 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## ## The files in this directory are simple utilities used by WHIZARD ## We create a library which is still to be combined with auxiliary libs. noinst_LTLIBRARIES = libutilities.la check_LTLIBRARIES = libutilities_ut.la libutilities_la_SOURCES = \ $(UTILITIES_MODULES) \ $(UTILITIES_SUBMODULES) UTILITIES_MODULES = \ file_utils.f90 \ file_registries.f90 \ string_utils.f90 \ format_utils.f90 \ format_defs.f90 \ numeric_utils.f90 \ binary_tree.f90 \ array_list.f90 \ queue.f90 \ iterator.f90 UTILITIES_SUBMODULES = \ file_utils_sub.f90 \ file_registries_sub.f90 \ string_utils_sub.f90 \ format_utils_sub.f90 \ numeric_utils_sub.f90 \ binary_tree_sub.f90 \ array_list_sub.f90 \ queue_sub.f90 \ iterator_sub.f90 libutilities_ut_la_SOURCES = \ - binary_tree_ut.f90 binary_tree_uti.f90 \ - array_list_ut.f90 array_list_uti.f90 \ - iterator_ut.f90 iterator_uti.f90 + numeric_utils_ut.f90 numeric_utils_uti.f90 \ + binary_tree_ut.f90 binary_tree_uti.f90 \ + array_list_ut.f90 array_list_uti.f90 \ + iterator_ut.f90 iterator_uti.f90 ## Omitting this would exclude it from the distribution dist_noinst_DATA = utilities.nw # Modules and installation # Dump module names into file Modules execmoddir = $(fmoddir)/whizard nodist_execmod_HEADERS = \ ${UTILITIES_MODULES:.f90=.$(FCMOD)} # Submodules must not be included here # Dump module names into file Modules libutilities_Modules = ${UTILITIES_MODULES:.f90=} ${libutilities_ut_la_SOURCES:.f90=} Modules: Makefile @for module in $(libutilities_Modules); do \ echo $$module >> $@.new; \ done @if diff $@ $@.new -q >/dev/null; then \ rm $@.new; \ else \ mv $@.new $@; echo "Modules updated"; \ fi BUILT_SOURCES = Modules ## Fortran module dependencies # Get module lists from other directories module_lists = \ ../basics/Modules \ ../testing/Modules $(module_lists): $(MAKE) -C `dirname $@` Modules Module_dependencies.sed: $(libutilities_la_SOURCES) \ $(libutilities_ut_la_SOURCES) Module_dependencies.sed: $(module_lists) @rm -f $@ echo 's/, *only:.*//' >> $@ echo 's/, *&//' >> $@ echo 's/, *.*=>.*//' >> $@ echo 's/$$/.lo/' >> $@ for list in $(module_lists); do \ dir="`dirname $$list`"; \ for mod in `cat $$list`; do \ echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \ done \ done DISTCLEANFILES = Module_dependencies.sed # The following line just says # include Makefile.depend # but in a portable fashion (depending on automake's AM_MAKE_INCLUDE @am__include@ @am__quote@Makefile.depend@am__quote@ Makefile.depend: Module_dependencies.sed Makefile.depend: $(libutilities_la_SOURCES) $(libutilities_ut_la_SOURCES) @rm -f $@ for src in $^; do \ module="`basename $$src | sed 's/\.f[90][0358]//'`"; \ grep '^ *use ' $$src \ | grep -v '!NODEP!' \ | sed -e 's/^ *use */'$$module'.lo: /' \ -f Module_dependencies.sed; \ done > $@ DISTCLEANFILES += Makefile.depend # Fortran90 module files are generated at the same time as object files .lo.$(FCMOD): @: # touch $@ AM_FCFLAGS = -I../basics -I../testing ######################################################################## # For the moment, the submodule dependencies will be hard-coded file_utils_sub.lo: file_utils.lo file_registries_sub.lo: file_registries.lo string_utils_sub.lo: string_utils.lo format_utils_sub.lo: format_utils.lo numeric_utils_sub.lo: numeric_utils.lo binary_tree_sub.lo: binary_tree.lo array_list_sub.lo: array_list.lo queue_sub.lo: queue.lo iterator_sub.lo: iterator.lo ######################################################################## ## Default Fortran compiler options ## Profiling if FC_USE_PROFILING AM_FCFLAGS += $(FCFLAGS_PROFILING) endif ## OpenMP if FC_USE_OPENMP AM_FCFLAGS += $(FCFLAGS_OPENMP) endif ## MPI if FC_USE_MPI AM_FCFLAGS += $(FCFLAGS_MPI) endif ######################################################################## ## Non-standard targets and dependencies ## (Re)create F90 sources from NOWEB source. if NOWEB_AVAILABLE PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw utilities.stamp: $(PRELUDE) $(srcdir)/utilities.nw $(POSTLUDE) @rm -f utilities.tmp @touch utilities.tmp for src in $(libutilities_la_SOURCES) $(libutilities_ut_la_SOURCES); do \ $(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \ done @mv -f utilities.tmp utilities.stamp $(libutilities_la_SOURCES) $(libutilities_ut_la_SOURCES): utilities.stamp ## Recover from the removal of $@ @if test -f $@; then :; else \ rm -f utilities.stamp; \ $(MAKE) $(AM_MAKEFLAGS) utilities.stamp; \ fi endif ######################################################################## ## Non-standard cleanup tasks ## Remove sources that can be recreated using NOWEB if NOWEB_AVAILABLE maintainer-clean-noweb: -rm -f *.f90 *.c endif .PHONY: maintainer-clean-noweb ## Remove those sources also if builddir and srcdir are different if NOWEB_AVAILABLE clean-noweb: test "$(srcdir)" != "." && rm -f *.f90 *.c || true endif .PHONY: clean-noweb ## Remove F90 module files clean-local: clean-noweb -rm -f utilities.stamp utilities.tmp -rm -f *.$(FCMOD) if FC_SUBMODULES -rm -f *.smod *.sub endif ## Remove backup files maintainer-clean-backup: -rm -f *~ .PHONY: maintainer-clean-backup ## Register additional clean targets maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup Index: trunk/src/physics/physics.nw =================================================================== --- trunk/src/physics/physics.nw (revision 8815) +++ trunk/src/physics/physics.nw (revision 8816) @@ -1,8379 +1,8420 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: physics and such \chapter{Physics} \includemodulegraph{physics} Here we collect definitions and functions that we need for (particle) physics in general, to make them available for the more specific needs of WHIZARD. \begin{description} \item[physics\_defs] Physical constants. \item[c\_particles] A simple data type for particles which is C compatible. \item[lorentz] Define three-vectors, four-vectors and Lorentz transformations and common operations for them. \item[phs\_point] Collections of Lorentz vectors. \item[sm\_physics] Here, running functions are stored for special kinematical setup like running coupling constants, Catani-Seymour dipoles, or Sudakov factors. \item[sm\_qcd] Definitions and methods for dealing with the running QCD coupling. \item[shower\_algorithms] Algorithms typically used in Parton Showers as well as in their matching to NLO computations, e.g. with the POWHEG method. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Physics Constants} There is also the generic [[constants]] module. The constants listed here are more specific for particle physics. <<[[physics_defs.f90]]>>= <> module physics_defs <> <> use constants, only: one, two, three <> <> <> <> interface <> end interface end module physics_defs @ %def physics_defs @ <<[[physics_defs_sub.f90]]>>= <> submodule (physics_defs) physics_defs_s implicit none contains <> end submodule physics_defs_s @ %def physics_defs_s @ \subsection{Units} Conversion from energy units to cross-section units. <>= real(default), parameter, public :: & conv = 0.38937966e12_default @ Conversion from millimeter to nanoseconds for lifetimes. <>= real(default), parameter, public :: & ns_per_mm = 1.e6_default / 299792458._default @ Rescaling factor. <>= real(default), parameter, public :: & pb_per_fb = 1.e-3_default @ String for the default energy and cross-section units. <>= character(*), parameter, public :: & energy_unit = "GeV" character(*), parameter, public :: & cross_section_unit = "fb" @ \subsection{SM and QCD constants} <>= real(default), parameter, public :: & NC = three, & CF = (NC**2 - one) / two / NC, & CA = NC, & TR = one / two @ \subsection{Parameter Reference values} These are used exclusively in the context of running QCD parameters. In other contexts, we rely on the uniform parameter set as provided by the model definition, modifiable by the user. <>= real(default), public, parameter :: MZ_REF = 91.188_default real(default), public, parameter :: ME_REF = 0.000510998928_default real(default), public, parameter :: ALPHA_QCD_MZ_REF = 0.1178_default real(default), public, parameter :: ALPHA_QED_ME_REF = 0.0072973525693_default real(default), public, parameter :: LAMBDA_QCD_REF = 200.e-3_default @ %def alpha_s_mz_ref mz_ref lambda_qcd_ref @ \subsection{Particle codes} Let us define a few particle codes independent of the model. We need an UNDEFINED value: <>= integer, parameter, public :: UNDEFINED = 0 @ %def UNDEFINED @ SM fermions: <>= integer, parameter, public :: DOWN_Q = 1 integer, parameter, public :: UP_Q = 2 integer, parameter, public :: STRANGE_Q = 3 integer, parameter, public :: CHARM_Q = 4 integer, parameter, public :: BOTTOM_Q = 5 integer, parameter, public :: TOP_Q = 6 integer, parameter, public :: ELECTRON = 11 integer, parameter, public :: ELECTRON_NEUTRINO = 12 integer, parameter, public :: MUON = 13 integer, parameter, public :: MUON_NEUTRINO = 14 integer, parameter, public :: TAU = 15 integer, parameter, public :: TAU_NEUTRINO = 16 @ %def ELECTRON MUON TAU @ Gauge bosons: <>= integer, parameter, public :: GLUON = 21 integer, parameter, public :: PHOTON = 22 integer, parameter, public :: PHOTON_OFFSHELL = -2002 integer, parameter, public :: PHOTON_ONSHELL = 2002 integer, parameter, public :: Z_BOSON = 23 integer, parameter, public :: W_BOSON = 24 @ %def GLUON PHOTON Z_BOSON W_BOSON @ Light mesons: <>= integer, parameter, public :: PION = 111 integer, parameter, public :: PIPLUS = 211 integer, parameter, public :: PIMINUS = - PIPLUS @ %def PION PIPLUS PIMINUS @ Di-Quarks: <>= integer, parameter, public :: UD0 = 2101 integer, parameter, public :: UD1 = 2103 integer, parameter, public :: UU1 = 2203 @ %def UD0 UD1 UU1 @ Mesons: <>= integer, parameter, public :: K0L = 130 integer, parameter, public :: K0S = 310 integer, parameter, public :: K0 = 311 integer, parameter, public :: KPLUS = 321 integer, parameter, public :: DPLUS = 411 integer, parameter, public :: D0 = 421 integer, parameter, public :: B0 = 511 integer, parameter, public :: BPLUS = 521 @ %def K0L K0S K0 KPLUS DPLUS D0 B0 BPLUS @ Light baryons: <>= integer, parameter, public :: PROTON = 2212 integer, parameter, public :: NEUTRON = 2112 integer, parameter, public :: DELTAPLUSPLUS = 2224 integer, parameter, public :: DELTAPLUS = 2214 integer, parameter, public :: DELTA0 = 2114 integer, parameter, public :: DELTAMINUS = 1114 @ %def PROTON NEUTRON DELTAPLUSPLUS DELTAPLUS DELTA0 DELTAMINUS @ Strange baryons: <>= integer, parameter, public :: SIGMAPLUS = 3222 integer, parameter, public :: SIGMA0 = 3212 integer, parameter, public :: SIGMAMINUS = 3112 @ %def SIGMAPLUS SIGMA0 SIGMAMINUS @ Charmed baryons: <>= integer, parameter, public :: SIGMACPLUSPLUS = 4222 integer, parameter, public :: SIGMACPLUS = 4212 integer, parameter, public :: SIGMAC0 = 4112 @ %def SIGMACPLUSPLUS SIGMACPLUS SIGMAC0 @ Bottom baryons: <>= integer, parameter, public :: SIGMAB0 = 5212 integer, parameter, public :: SIGMABPLUS = 5222 @ %def SIGMAB0 SIGMABPLUS @ 81-100 are reserved for internal codes. Hadron and beam remnants: <>= integer, parameter, public :: BEAM_REMNANT = 9999 integer, parameter, public :: HADRON_REMNANT = 90 integer, parameter, public :: HADRON_REMNANT_SINGLET = 91 integer, parameter, public :: HADRON_REMNANT_TRIPLET = 92 integer, parameter, public :: HADRON_REMNANT_OCTET = 93 @ %def BEAM_REMNANT HADRON_REMNANT @ %def HADRON_REMNANT_SINGLET HADRON_REMNANT_TRIPLET HADRON_REMNANT_OCTET @ Further particle codes for internal use: <>= integer, parameter, public :: INTERNAL = 94 integer, parameter, public :: INVALID = 97 integer, parameter, public :: COMPOSITE = 99 @ %def INTERNAL INVALID COMPOSITE @ \subsection{Spin codes} Somewhat redundant, but for better readability we define named constants for spin types. If the mass is nonzero, this is equal to the number of degrees of freedom. <>= integer, parameter, public:: UNKNOWN = 0 integer, parameter, public :: SCALAR = 1, SPINOR = 2, VECTOR = 3, & VECTORSPINOR = 4, TENSOR = 5 @ %def UNKNOWN SCALAR SPINOR VECTOR VECTORSPINOR TENSOR @ Isospin types and charge types are counted in an analogous way, where charge type 1 is charge 0, 2 is charge 1/3, and so on. Zero always means unknown. Note that charge and isospin types have an explicit sign. Color types are defined as the dimension of the representation. \subsection{NLO status codes} Used to specify whether a [[term_instance_t]] of a [[process_instance_t]] is associated with a Born, real-subtracted, virtual-subtracted or subtraction-dummy matrix element. <>= integer, parameter, public :: BORN = 0 integer, parameter, public :: NLO_REAL = 1 integer, parameter, public :: NLO_VIRTUAL = 2 integer, parameter, public :: NLO_MISMATCH = 3 integer, parameter, public :: NLO_DGLAP = 4 integer, parameter, public :: NLO_SUBTRACTION = 5 integer, parameter, public :: NLO_FULL = 6 integer, parameter, public :: GKS = 7 integer, parameter, public :: COMPONENT_UNDEFINED = 99 @ % def BORN, NLO_REAL, NLO_VIRTUAL, NLO_SUBTRACTION, GKS @ [[NLO_FULL]] is not strictly a component status code but having it is convenient. We define the number of additional subtractions for beam-involved NLO calculations. Each subtraction refers to a rescaling of one of two beams. Obviously, this approach is not flexible enough to support setups with just a single beam described by a structure function. <>= integer, parameter, public :: n_beams_rescaled = 2 @ %def n_beams_rescaled @ +Orders of the electron PDFs. +<>= + integer, parameter, public :: EPDF_LL = 0 + integer, parameter, public :: EPDF_NLL = 1 + +@ %def EPDF_LL EPDF_NLL +@ <>= public :: component_status <>= interface component_status module procedure component_status_of_string module procedure component_status_to_string end interface <>= elemental module function component_status_of_string (string) result (i) integer :: i type(string_t), intent(in) :: string end function component_status_of_string elemental module function component_status_to_string (i) result (string) type(string_t) :: string integer, intent(in) :: i end function component_status_to_string <>= elemental module function component_status_of_string (string) result (i) integer :: i type(string_t), intent(in) :: string select case (char(string)) case ("born") i = BORN case ("real") i = NLO_REAL case ("virtual") i = NLO_VIRTUAL case ("mismatch") i = NLO_MISMATCH case ("dglap") i = NLO_DGLAP case ("subtraction") i = NLO_SUBTRACTION case ("full") i = NLO_FULL case ("GKS") i = GKS case default i = COMPONENT_UNDEFINED end select end function component_status_of_string elemental module function component_status_to_string (i) result (string) type(string_t) :: string integer, intent(in) :: i select case (i) case (BORN) string = "born" case (NLO_REAL) string = "real" case (NLO_VIRTUAL) string = "virtual" case (NLO_MISMATCH) string = "mismatch" case (NLO_DGLAP) string = "dglap" case (NLO_SUBTRACTION) string = "subtraction" case (NLO_FULL) string = "full" case (GKS) string = "GKS" case default string = "undefined" end select end function component_status_to_string @ %def component_status @ <>= public :: is_nlo_component <>= elemental module function is_nlo_component (comp) result (is_nlo) logical :: is_nlo integer, intent(in) :: comp end function is_nlo_component <>= elemental module function is_nlo_component (comp) result (is_nlo) logical :: is_nlo integer, intent(in) :: comp select case (comp) case (BORN : GKS) is_nlo = .true. case default is_nlo = .false. end select end function is_nlo_component @ %def is_nlo_component @ <>= public :: is_subtraction_component <>= module function is_subtraction_component (emitter, nlo_type) result (is_subtraction) logical :: is_subtraction integer, intent(in) :: emitter, nlo_type end function is_subtraction_component <>= module function is_subtraction_component (emitter, nlo_type) result (is_subtraction) logical :: is_subtraction integer, intent(in) :: emitter, nlo_type is_subtraction = nlo_type == NLO_REAL .and. emitter < 0 end function is_subtraction_component @ %def is_subtraction_component @ \subsection{Threshold} Some commonly used variables for the threshold computation <>= integer, parameter, public :: THR_POS_WP = 3 integer, parameter, public :: THR_POS_WM = 4 integer, parameter, public :: THR_POS_B = 5 integer, parameter, public :: THR_POS_BBAR = 6 integer, parameter, public :: THR_POS_GLUON = 7 integer, parameter, public :: THR_EMITTER_OFFSET = 4 integer, parameter, public :: NO_FACTORIZATION = 0 integer, parameter, public :: FACTORIZATION_THRESHOLD = 1 integer, dimension(2), parameter, public :: ass_quark = [5, 6] integer, dimension(2), parameter, public :: ass_boson = [3, 4] integer, parameter, public :: PROC_MODE_UNDEFINED = 0 integer, parameter, public :: PROC_MODE_TT = 1 integer, parameter, public :: PROC_MODE_WBWB = 2 @ @ <>= public :: thr_leg <>= module function thr_leg (emitter) result (leg) integer :: leg integer, intent(in) :: emitter end function thr_leg <>= module function thr_leg (emitter) result (leg) integer :: leg integer, intent(in) :: emitter leg = emitter - THR_EMITTER_OFFSET end function thr_leg @ %def thr_leg @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{C-compatible Particle Type} For easy communication with C code, we introduce a simple C-compatible type for particles. The components are either default C integers or default C doubles. The [[c_prt]] type is transparent, and its contents should be regarded as part of the interface. <<[[c_particles.f90]]>>= <> module c_particles use, intrinsic :: iso_c_binding !NODEP! <> <> <> interface <> end interface end module c_particles @ %def c_particles @ <<[[c_particles_sub.f90]]>>= <> submodule (c_particles) c_particles_s use io_units use format_defs, only: FMT_14, FMT_19 implicit none contains <> end submodule c_particles_s @ %def c_particles_s @ <>= public :: c_prt_t <>= type, bind(C) :: c_prt_t integer(c_int) :: type = 0 integer(c_int) :: pdg = 0 integer(c_int) :: polarized = 0 integer(c_int) :: h = 0 real(c_double) :: pe = 0 real(c_double) :: px = 0 real(c_double) :: py = 0 real(c_double) :: pz = 0 real(c_double) :: p2 = 0 end type c_prt_t @ %def c_prt_t @ This is for debugging only, there is no C binding. It is a simplified version of [[prt_write]]. <>= public :: c_prt_write <>= module subroutine c_prt_write (prt, unit) type(c_prt_t), intent(in) :: prt integer, intent(in), optional :: unit end subroutine c_prt_write <>= module subroutine c_prt_write (prt, unit) type(c_prt_t), intent(in) :: prt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)", advance="no") "prt(" write (u, "(I0,':')", advance="no") prt%type if (prt%polarized /= 0) then write (u, "(I0,'/',I0,'|')", advance="no") prt%pdg, prt%h else write (u, "(I0,'|')", advance="no") prt%pdg end if write (u, "(" // FMT_14 // ",';'," // FMT_14 // ",','," // & FMT_14 // ",','," // FMT_14 // ")", advance="no") & prt%pe, prt%px, prt%py, prt%pz write (u, "('|'," // FMT_19 // ")", advance="no") prt%p2 write (u, "(A)") ")" end subroutine c_prt_write @ %def c_prt_write @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Lorentz algebra} Define Lorentz vectors, three-vectors, boosts, and some functions to manipulate them. To make maximum use of this, all functions, if possible, are declared elemental (or pure, if this is not possible). <<[[lorentz.f90]]>>= <> module lorentz <> use constants, only: zero, one use c_particles <> <> <> <> <> <> <> interface <> end interface end module lorentz @ %def lorentz @ <<[[lorentz_sub.f90]]>>= <> submodule (lorentz) lorentz_s use constants, only: pi, twopi, degree, two, tiny_07, eps0 use numeric_utils use io_units use format_defs, only: FMT_11, FMT_13, FMT_15, FMT_19 use format_utils, only: pac_fmt use diagnostics implicit none contains <> end submodule lorentz_s @ %def lorentz_s @ \subsection{Three-vectors} First of all, let us introduce three-vectors in a trivial way. The functions and overloaded elementary operations clearly are too much overhead, but we like to keep the interface for three-vectors and four-vectors exactly parallel. By the way, we might attach a label to a vector by extending the type definition later. <>= public :: vector3_t <>= type :: vector3_t real(default), dimension(3) :: p end type vector3_t @ %def vector3_t @ Output a vector <>= public :: vector3_write <>= module subroutine vector3_write (p, unit, testflag) type(vector3_t), intent(in) :: p integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine vector3_write <>= module subroutine vector3_write (p, unit, testflag) type(vector3_t), intent(in) :: p integer, intent(in), optional :: unit logical, intent(in), optional :: testflag character(len=7) :: fmt integer :: u u = given_output_unit (unit); if (u < 0) return call pac_fmt (fmt, FMT_19, FMT_15, testflag) write(u, "(1x,A,3(1x," // fmt // "))") 'P = ', p%p end subroutine vector3_write @ %def vector3_write @ This is a three-vector with zero components <>= public :: vector3_null <>= type(vector3_t), parameter :: vector3_null = & vector3_t ([ zero, zero, zero ]) @ %def vector3_null @ Canonical three-vector: <>= public :: vector3_canonical <>= elemental module function vector3_canonical (k) result (p) type(vector3_t) :: p integer, intent(in) :: k end function vector3_canonical <>= elemental module function vector3_canonical (k) result (p) type(vector3_t) :: p integer, intent(in) :: k p = vector3_null p%p(k) = 1 end function vector3_canonical @ %def vector3_canonical @ A moving particle ($k$-axis, or arbitrary axis). Note that the function for the generic momentum cannot be elemental. <>= public :: vector3_moving <>= interface vector3_moving module procedure vector3_moving_canonical module procedure vector3_moving_generic end interface <>= elemental module function vector3_moving_canonical (p, k) result(q) type(vector3_t) :: q real(default), intent(in) :: p integer, intent(in) :: k end function vector3_moving_canonical pure module function vector3_moving_generic (p) result(q) real(default), dimension(3), intent(in) :: p type(vector3_t) :: q end function vector3_moving_generic <>= elemental module function vector3_moving_canonical (p, k) result(q) type(vector3_t) :: q real(default), intent(in) :: p integer, intent(in) :: k q = vector3_null q%p(k) = p end function vector3_moving_canonical pure module function vector3_moving_generic (p) result(q) real(default), dimension(3), intent(in) :: p type(vector3_t) :: q q%p = p end function vector3_moving_generic @ %def vector3_moving @ Equality and inequality <>= public :: operator(==), operator(/=) <>= interface operator(==) module procedure vector3_eq end interface interface operator(/=) module procedure vector3_neq end interface <>= elemental module function vector3_eq (p, q) result (r) logical :: r type(vector3_t), intent(in) :: p,q end function vector3_eq elemental module function vector3_neq (p, q) result (r) logical :: r type(vector3_t), intent(in) :: p,q end function vector3_neq <>= elemental module function vector3_eq (p, q) result (r) logical :: r type(vector3_t), intent(in) :: p,q r = all (abs (p%p - q%p) < eps0) end function vector3_eq elemental module function vector3_neq (p, q) result (r) logical :: r type(vector3_t), intent(in) :: p,q r = any (abs(p%p - q%p) > eps0) end function vector3_neq @ %def == /= @ Define addition and subtraction <>= public :: operator(+), operator(-) <>= interface operator(+) module procedure add_vector3 end interface interface operator(-) module procedure sub_vector3 end interface <>= elemental module function add_vector3 (p, q) result (r) type(vector3_t) :: r type(vector3_t), intent(in) :: p,q end function add_vector3 elemental module function sub_vector3 (p, q) result (r) type(vector3_t) :: r type(vector3_t), intent(in) :: p,q end function sub_vector3 <>= elemental module function add_vector3 (p, q) result (r) type(vector3_t) :: r type(vector3_t), intent(in) :: p,q r%p = p%p + q%p end function add_vector3 elemental module function sub_vector3 (p, q) result (r) type(vector3_t) :: r type(vector3_t), intent(in) :: p,q r%p = p%p - q%p end function sub_vector3 @ %def + - @ The multiplication sign is overloaded with scalar multiplication; similarly division: <>= public :: operator(*), operator(/) <>= interface operator(*) module procedure prod_integer_vector3, prod_vector3_integer module procedure prod_real_vector3, prod_vector3_real end interface interface operator(/) module procedure div_vector3_real, div_vector3_integer end interface <>= elemental module function prod_real_vector3 (s, p) result (q) type(vector3_t) :: q real(default), intent(in) :: s type(vector3_t), intent(in) :: p end function prod_real_vector3 elemental module function prod_vector3_real (p, s) result (q) type(vector3_t) :: q real(default), intent(in) :: s type(vector3_t), intent(in) :: p end function prod_vector3_real elemental module function div_vector3_real (p, s) result (q) type(vector3_t) :: q real(default), intent(in) :: s type(vector3_t), intent(in) :: p end function div_vector3_real elemental module function prod_integer_vector3 (s, p) result (q) type(vector3_t) :: q integer, intent(in) :: s type(vector3_t), intent(in) :: p end function prod_integer_vector3 elemental module function prod_vector3_integer (p, s) result (q) type(vector3_t) :: q integer, intent(in) :: s type(vector3_t), intent(in) :: p end function prod_vector3_integer elemental module function div_vector3_integer (p, s) result (q) type(vector3_t) :: q integer, intent(in) :: s type(vector3_t), intent(in) :: p end function div_vector3_integer <>= elemental module function prod_real_vector3 (s, p) result (q) type(vector3_t) :: q real(default), intent(in) :: s type(vector3_t), intent(in) :: p q%p = s * p%p end function prod_real_vector3 elemental module function prod_vector3_real (p, s) result (q) type(vector3_t) :: q real(default), intent(in) :: s type(vector3_t), intent(in) :: p q%p = s * p%p end function prod_vector3_real elemental module function div_vector3_real (p, s) result (q) type(vector3_t) :: q real(default), intent(in) :: s type(vector3_t), intent(in) :: p q%p = p%p/s end function div_vector3_real elemental module function prod_integer_vector3 (s, p) result (q) type(vector3_t) :: q integer, intent(in) :: s type(vector3_t), intent(in) :: p q%p = s * p%p end function prod_integer_vector3 elemental module function prod_vector3_integer (p, s) result (q) type(vector3_t) :: q integer, intent(in) :: s type(vector3_t), intent(in) :: p q%p = s * p%p end function prod_vector3_integer elemental module function div_vector3_integer (p, s) result (q) type(vector3_t) :: q integer, intent(in) :: s type(vector3_t), intent(in) :: p q%p = p%p/s end function div_vector3_integer @ %def * / @ The multiplication sign can also indicate scalar products: <>= interface operator(*) module procedure prod_vector3 end interface <>= elemental module function prod_vector3 (p, q) result (s) real(default) :: s type(vector3_t), intent(in) :: p,q end function prod_vector3 <>= elemental module function prod_vector3 (p, q) result (s) real(default) :: s type(vector3_t), intent(in) :: p,q s = dot_product (p%p, q%p) end function prod_vector3 @ %def * <>= public :: cross_product <>= interface cross_product module procedure vector3_cross_product end interface <>= elemental module function vector3_cross_product (p, q) result (r) type(vector3_t) :: r type(vector3_t), intent(in) :: p,q end function vector3_cross_product <>= elemental module function vector3_cross_product (p, q) result (r) type(vector3_t) :: r type(vector3_t), intent(in) :: p,q integer :: i do i=1,3 r%p(i) = dot_product (p%p, matmul(epsilon_three(i,:,:), q%p)) end do end function vector3_cross_product @ %def cross_product @ Exponentiation is defined only for integer powers. Odd powers mean take the square root; so [[p**1]] is the length of [[p]]. <>= public :: operator(**) <>= interface operator(**) module procedure power_vector3 end interface <>= elemental module function power_vector3 (p, e) result (s) real(default) :: s type(vector3_t), intent(in) :: p integer, intent(in) :: e end function power_vector3 <>= elemental module function power_vector3 (p, e) result (s) real(default) :: s type(vector3_t), intent(in) :: p integer, intent(in) :: e s = dot_product (p%p, p%p) if (e/=2) then if (mod(e,2)==0) then s = s**(e/2) else s = sqrt(s)**e end if end if end function power_vector3 @ %def ** @ Finally, we need a negation. <>= interface operator(-) module procedure negate_vector3 end interface <>= elemental module function negate_vector3 (p) result (q) type(vector3_t) :: q type(vector3_t), intent(in) :: p end function negate_vector3 <>= elemental module function negate_vector3 (p) result (q) type(vector3_t) :: q type(vector3_t), intent(in) :: p integer :: i do i = 1, 3 if (abs (p%p(i)) < eps0) then q%p(i) = 0 else q%p(i) = -p%p(i) end if end do end function negate_vector3 @ %def - @ The sum function can be useful: <>= public :: sum <>= interface sum module procedure sum_vector3 end interface @ %def sum @ <>= public :: vector3_set_component <>= module subroutine vector3_set_component (p, i, value) type(vector3_t), intent(inout) :: p integer, intent(in) :: i real(default), intent(in) :: value end subroutine vector3_set_component <>= module subroutine vector3_set_component (p, i, value) type(vector3_t), intent(inout) :: p integer, intent(in) :: i real(default), intent(in) :: value p%p(i) = value end subroutine vector3_set_component @ %def vector3_set_component @ <>= pure module function sum_vector3 (p) result (q) type(vector3_t) :: q type(vector3_t), dimension(:), intent(in) :: p end function sum_vector3 <>= pure module function sum_vector3 (p) result (q) type(vector3_t) :: q type(vector3_t), dimension(:), intent(in) :: p integer :: i do i=1, 3 q%p(i) = sum (p%p(i)) end do end function sum_vector3 @ %def sum @ Any component: <>= public :: vector3_get_component @ %def component <>= elemental module function vector3_get_component (p, k) result (c) type(vector3_t), intent(in) :: p integer, intent(in) :: k real(default) :: c end function vector3_get_component <>= elemental module function vector3_get_component (p, k) result (c) type(vector3_t), intent(in) :: p integer, intent(in) :: k real(default) :: c c = p%p(k) end function vector3_get_component @ %def vector3_get_component @ Extract all components. This is not elemental. <>= public :: vector3_get_components <>= pure module function vector3_get_components (p) result (a) type(vector3_t), intent(in) :: p real(default), dimension(3) :: a end function vector3_get_components <>= pure module function vector3_get_components (p) result (a) type(vector3_t), intent(in) :: p real(default), dimension(3) :: a a = p%p end function vector3_get_components @ %def vector3_get_components @ This function returns the direction of a three-vector, i.e., a normalized three-vector. If the vector is null, we return a null vector. <>= public :: direction <>= interface direction module procedure vector3_get_direction end interface <>= elemental module function vector3_get_direction (p) result (q) type(vector3_t) :: q type(vector3_t), intent(in) :: p end function vector3_get_direction <>= elemental module function vector3_get_direction (p) result (q) type(vector3_t) :: q type(vector3_t), intent(in) :: p real(default) :: pp pp = p**1 if (pp > eps0) then q%p = p%p / pp else q%p = 0 end if end function vector3_get_direction @ %def direction @ \subsection{Four-vectors} In four-vectors the zero-component needs special treatment, therefore we do not use the standard operations. Sure, we pay for the extra layer of abstraction by losing efficiency; so we have to assume that the time-critical applications do not involve four-vector operations. <>= public :: vector4_t <>= type :: vector4_t real(default), dimension(0:3) :: p = & [zero, zero, zero, zero] contains <> end type vector4_t @ %def vector4_t @ Output a vector <>= public :: vector4_write <>= procedure :: write => vector4_write <>= module subroutine vector4_write & (p, unit, show_mass, testflag, compressed, ultra) class(vector4_t), intent(in) :: p integer, intent(in), optional :: unit logical, intent(in), optional :: show_mass, testflag, compressed, ultra end subroutine vector4_write <>= module subroutine vector4_write & (p, unit, show_mass, testflag, compressed, ultra) class(vector4_t), intent(in) :: p integer, intent(in), optional :: unit logical, intent(in), optional :: show_mass, testflag, compressed, ultra logical :: comp, sm, tf, extreme integer :: u character(len=7) :: fmt real(default) :: m comp = .false.; if (present (compressed)) comp = compressed sm = .false.; if (present (show_mass)) sm = show_mass tf = .false.; if (present (testflag)) tf = testflag extreme = .false.; if (present (ultra)) extreme = ultra if (extreme) then call pac_fmt (fmt, FMT_19, FMT_11, testflag) else call pac_fmt (fmt, FMT_19, FMT_13, testflag) end if u = given_output_unit (unit); if (u < 0) return if (comp) then write (u, "(4(F12.3,1X))", advance="no") p%p(0:3) else write (u, "(1x,A,1x," // fmt // ")") 'E = ', p%p(0) write (u, "(1x,A,3(1x," // fmt // "))") 'P = ', p%p(1:) if (sm) then m = p**1 if (tf) call pacify (m, tolerance = 1E-6_default) write (u, "(1x,A,1x," // fmt // ")") 'M = ', m end if end if end subroutine vector4_write @ %def vector4_write @ Binary I/O <>= public :: vector4_write_raw public :: vector4_read_raw <>= module subroutine vector4_write_raw (p, u) type(vector4_t), intent(in) :: p integer, intent(in) :: u end subroutine vector4_write_raw module subroutine vector4_read_raw (p, u, iostat) type(vector4_t), intent(out) :: p integer, intent(in) :: u integer, intent(out), optional :: iostat end subroutine vector4_read_raw <>= module subroutine vector4_write_raw (p, u) type(vector4_t), intent(in) :: p integer, intent(in) :: u write (u) p%p end subroutine vector4_write_raw module subroutine vector4_read_raw (p, u, iostat) type(vector4_t), intent(out) :: p integer, intent(in) :: u integer, intent(out), optional :: iostat read (u, iostat=iostat) p%p end subroutine vector4_read_raw @ %def vector4_write_raw vector4_read_raw @ This is a four-vector with zero components <>= public :: vector4_null <>= type(vector4_t), parameter :: vector4_null = & vector4_t ([ zero, zero, zero, zero ]) @ %def vector4_null @ Canonical four-vector: <>= public :: vector4_canonical <>= elemental module function vector4_canonical (k) result (p) type(vector4_t) :: p integer, intent(in) :: k end function vector4_canonical <>= elemental module function vector4_canonical (k) result (p) type(vector4_t) :: p integer, intent(in) :: k p = vector4_null p%p(k) = 1 end function vector4_canonical @ %def vector4_canonical @ A particle at rest: <>= public :: vector4_at_rest <>= elemental module function vector4_at_rest (m) result (p) type(vector4_t) :: p real(default), intent(in) :: m end function vector4_at_rest <>= elemental module function vector4_at_rest (m) result (p) type(vector4_t) :: p real(default), intent(in) :: m p = vector4_t ([ m, zero, zero, zero ]) end function vector4_at_rest @ %def vector4_at_rest @ A moving particle ($k$-axis, or arbitrary axis) <>= public :: vector4_moving <>= interface vector4_moving module procedure vector4_moving_canonical module procedure vector4_moving_generic end interface <>= elemental module function vector4_moving_canonical (E, p, k) result (q) type(vector4_t) :: q real(default), intent(in) :: E, p integer, intent(in) :: k end function vector4_moving_canonical elemental module function vector4_moving_generic (E, p) result (q) type(vector4_t) :: q real(default), intent(in) :: E type(vector3_t), intent(in) :: p end function vector4_moving_generic <>= elemental module function vector4_moving_canonical (E, p, k) result (q) type(vector4_t) :: q real(default), intent(in) :: E, p integer, intent(in) :: k q = vector4_at_rest(E) q%p(k) = p end function vector4_moving_canonical elemental module function vector4_moving_generic (E, p) result (q) type(vector4_t) :: q real(default), intent(in) :: E type(vector3_t), intent(in) :: p q%p(0) = E q%p(1:) = p%p end function vector4_moving_generic @ %def vector4_moving @ Equality and inequality <>= interface operator(==) module procedure vector4_eq end interface interface operator(/=) module procedure vector4_neq end interface <>= elemental module function vector4_eq (p, q) result (r) logical :: r type(vector4_t), intent(in) :: p,q end function vector4_eq elemental module function vector4_neq (p, q) result (r) logical :: r type(vector4_t), intent(in) :: p,q end function vector4_neq <>= elemental module function vector4_eq (p, q) result (r) logical :: r type(vector4_t), intent(in) :: p,q r = all (abs (p%p - q%p) < eps0) end function vector4_eq elemental module function vector4_neq (p, q) result (r) logical :: r type(vector4_t), intent(in) :: p,q r = any (abs (p%p - q%p) > eps0) end function vector4_neq @ %def == /= @ Addition and subtraction: <>= interface operator(+) module procedure add_vector4 end interface interface operator(-) module procedure sub_vector4 end interface <>= elemental module function add_vector4 (p,q) result (r) type(vector4_t) :: r type(vector4_t), intent(in) :: p,q end function add_vector4 elemental module function sub_vector4 (p,q) result (r) type(vector4_t) :: r type(vector4_t), intent(in) :: p,q end function sub_vector4 <>= elemental module function add_vector4 (p,q) result (r) type(vector4_t) :: r type(vector4_t), intent(in) :: p,q r%p = p%p + q%p end function add_vector4 elemental module function sub_vector4 (p,q) result (r) type(vector4_t) :: r type(vector4_t), intent(in) :: p,q r%p = p%p - q%p end function sub_vector4 @ %def + - @ We also need scalar multiplication and division: <>= interface operator(*) module procedure prod_real_vector4, prod_vector4_real module procedure prod_integer_vector4, prod_vector4_integer end interface interface operator(/) module procedure div_vector4_real module procedure div_vector4_integer end interface <>= elemental module function prod_real_vector4 (s, p) result (q) type(vector4_t) :: q real(default), intent(in) :: s type(vector4_t), intent(in) :: p end function prod_real_vector4 elemental module function prod_vector4_real (p, s) result (q) type(vector4_t) :: q real(default), intent(in) :: s type(vector4_t), intent(in) :: p end function prod_vector4_real elemental module function div_vector4_real (p, s) result (q) type(vector4_t) :: q real(default), intent(in) :: s type(vector4_t), intent(in) :: p end function div_vector4_real elemental module function prod_integer_vector4 (s, p) result (q) type(vector4_t) :: q integer, intent(in) :: s type(vector4_t), intent(in) :: p end function prod_integer_vector4 elemental module function prod_vector4_integer (p, s) result (q) type(vector4_t) :: q integer, intent(in) :: s type(vector4_t), intent(in) :: p end function prod_vector4_integer elemental module function div_vector4_integer (p, s) result (q) type(vector4_t) :: q integer, intent(in) :: s type(vector4_t), intent(in) :: p end function div_vector4_integer <>= elemental module function prod_real_vector4 (s, p) result (q) type(vector4_t) :: q real(default), intent(in) :: s type(vector4_t), intent(in) :: p q%p = s * p%p end function prod_real_vector4 elemental module function prod_vector4_real (p, s) result (q) type(vector4_t) :: q real(default), intent(in) :: s type(vector4_t), intent(in) :: p q%p = s * p%p end function prod_vector4_real elemental module function div_vector4_real (p, s) result (q) type(vector4_t) :: q real(default), intent(in) :: s type(vector4_t), intent(in) :: p q%p = p%p/s end function div_vector4_real elemental module function prod_integer_vector4 (s, p) result (q) type(vector4_t) :: q integer, intent(in) :: s type(vector4_t), intent(in) :: p q%p = s * p%p end function prod_integer_vector4 elemental module function prod_vector4_integer (p, s) result (q) type(vector4_t) :: q integer, intent(in) :: s type(vector4_t), intent(in) :: p q%p = s * p%p end function prod_vector4_integer elemental module function div_vector4_integer (p, s) result (q) type(vector4_t) :: q integer, intent(in) :: s type(vector4_t), intent(in) :: p q%p = p%p/s end function div_vector4_integer @ %def * / @ Scalar products and squares in the Minkowski sense: <>= interface operator(*) module procedure prod_vector4 end interface interface operator(**) module procedure power_vector4 end interface <>= elemental module function prod_vector4 (p, q) result (s) real(default) :: s type(vector4_t), intent(in) :: p,q end function prod_vector4 <>= elemental module function prod_vector4 (p, q) result (s) real(default) :: s type(vector4_t), intent(in) :: p,q s = p%p(0)*q%p(0) - dot_product(p%p(1:), q%p(1:)) end function prod_vector4 @ %def * @ The power operation for four-vectors is signed, i.e., [[p**1]] is positive for timelike and negative for spacelike vectors. Note that [[(p**1)**2]] is not necessarily equal to [[p**2]]. <>= elemental module function power_vector4 (p, e) result (s) real(default) :: s type(vector4_t), intent(in) :: p integer, intent(in) :: e end function power_vector4 <>= elemental module function power_vector4 (p, e) result (s) real(default) :: s type(vector4_t), intent(in) :: p integer, intent(in) :: e s = p * p if (e /= 2) then if (mod(e, 2) == 0) then s = s**(e / 2) else if (s >= 0) then s = sqrt(s)**e else s = -(sqrt(abs(s))**e) end if end if end function power_vector4 @ %def ** @ Finally, we introduce a negation <>= interface operator(-) module procedure negate_vector4 end interface <>= elemental module function negate_vector4 (p) result (q) type(vector4_t) :: q type(vector4_t), intent(in) :: p end function negate_vector4 <>= elemental module function negate_vector4 (p) result (q) type(vector4_t) :: q type(vector4_t), intent(in) :: p integer :: i do i = 0, 3 if (abs (p%p(i)) < eps0) then q%p(i) = 0 else q%p(i) = -p%p(i) end if end do end function negate_vector4 @ %def - @ The sum function can be useful: <>= interface sum module procedure sum_vector4, sum_vector4_mask end interface @ %def sum @ <>= pure module function sum_vector4 (p) result (q) type(vector4_t) :: q type(vector4_t), dimension(:), intent(in) :: p end function sum_vector4 pure module function sum_vector4_mask (p, mask) result (q) type(vector4_t) :: q type(vector4_t), dimension(:), intent(in) :: p logical, dimension(:), intent(in) :: mask end function sum_vector4_mask <>= pure module function sum_vector4 (p) result (q) type(vector4_t) :: q type(vector4_t), dimension(:), intent(in) :: p integer :: i do i = 0, 3 q%p(i) = sum (p%p(i)) end do end function sum_vector4 pure module function sum_vector4_mask (p, mask) result (q) type(vector4_t) :: q type(vector4_t), dimension(:), intent(in) :: p logical, dimension(:), intent(in) :: mask integer :: i do i = 0, 3 q%p(i) = sum (p%p(i), mask=mask) end do end function sum_vector4_mask @ %def sum @ \subsection{Conversions} Manually set a component of the four-vector: <>= public :: vector4_set_component <>= module subroutine vector4_set_component (p, k, c) type(vector4_t), intent(inout) :: p integer, intent(in) :: k real(default), intent(in) :: c end subroutine vector4_set_component <>= module subroutine vector4_set_component (p, k, c) type(vector4_t), intent(inout) :: p integer, intent(in) :: k real(default), intent(in) :: c p%p(k) = c end subroutine vector4_set_component @ %def vector4_get_component Any component: <>= public :: vector4_get_component <>= elemental module function vector4_get_component (p, k) result (c) real(default) :: c type(vector4_t), intent(in) :: p integer, intent(in) :: k end function vector4_get_component <>= elemental module function vector4_get_component (p, k) result (c) real(default) :: c type(vector4_t), intent(in) :: p integer, intent(in) :: k c = p%p(k) end function vector4_get_component @ %def vector4_get_component @ Extract all components. This is not elemental. <>= public :: vector4_get_components <>= pure module function vector4_get_components (p) result (a) real(default), dimension(0:3) :: a type(vector4_t), intent(in) :: p end function vector4_get_components <>= pure module function vector4_get_components (p) result (a) real(default), dimension(0:3) :: a type(vector4_t), intent(in) :: p a = p%p end function vector4_get_components @ %def vector4_get_components @ This function returns the space part of a four-vector, such that we can apply three-vector operations on it: <>= public :: space_part <>= interface space_part module procedure vector4_get_space_part end interface <>= elemental module function vector4_get_space_part (p) result (q) type(vector3_t) :: q type(vector4_t), intent(in) :: p end function vector4_get_space_part <>= elemental module function vector4_get_space_part (p) result (q) type(vector3_t) :: q type(vector4_t), intent(in) :: p q%p = p%p(1:) end function vector4_get_space_part @ %def space_part @ This function returns the direction of a four-vector, i.e., a normalized three-vector. If the four-vector has zero space part, we return a null vector. <>= interface direction module procedure vector4_get_direction end interface <>= elemental module function vector4_get_direction (p) result (q) type(vector3_t) :: q type(vector4_t), intent(in) :: p end function vector4_get_direction <>= elemental module function vector4_get_direction (p) result (q) type(vector3_t) :: q type(vector4_t), intent(in) :: p real(default) :: qq q%p = p%p(1:) qq = q**1 if (abs(qq) > eps0) then q%p = q%p / qq else q%p = 0 end if end function vector4_get_direction @ %def direction @ Change the sign of the spatial part of a four-vector <>= public :: vector4_invert_direction <>= elemental module subroutine vector4_invert_direction (p) type(vector4_t), intent(inout) :: p end subroutine vector4_invert_direction <>= elemental module subroutine vector4_invert_direction (p) type(vector4_t), intent(inout) :: p p%p(1:3) = -p%p(1:3) end subroutine vector4_invert_direction @ %def vector4_invert_direction @ This function returns the four-vector as an ordinary array. A second version for an array of four-vectors. <>= public :: assignment (=) <>= interface assignment (=) module procedure array_from_vector4_1, array_from_vector4_2, & array_from_vector3_1, array_from_vector3_2, & vector4_from_array, vector3_from_array end interface <>= pure module subroutine array_from_vector4_1 (a, p) real(default), dimension(:), intent(out) :: a type(vector4_t), intent(in) :: p end subroutine array_from_vector4_1 pure module subroutine array_from_vector4_2 (a, p) type(vector4_t), dimension(:), intent(in) :: p real(default), dimension(:,:), intent(out) :: a end subroutine array_from_vector4_2 pure module subroutine array_from_vector3_1 (a, p) real(default), dimension(:), intent(out) :: a type(vector3_t), intent(in) :: p end subroutine array_from_vector3_1 pure module subroutine array_from_vector3_2 (a, p) type(vector3_t), dimension(:), intent(in) :: p real(default), dimension(:,:), intent(out) :: a end subroutine array_from_vector3_2 pure module subroutine vector4_from_array (p, a) type(vector4_t), intent(out) :: p real(default), dimension(:), intent(in) :: a end subroutine vector4_from_array pure module subroutine vector3_from_array (p, a) type(vector3_t), intent(out) :: p real(default), dimension(:), intent(in) :: a end subroutine vector3_from_array <>= pure module subroutine array_from_vector4_1 (a, p) real(default), dimension(:), intent(out) :: a type(vector4_t), intent(in) :: p a = p%p end subroutine array_from_vector4_1 pure module subroutine array_from_vector4_2 (a, p) type(vector4_t), dimension(:), intent(in) :: p real(default), dimension(:,:), intent(out) :: a integer :: i forall (i=1:size(p)) a(:,i) = p(i)%p end forall end subroutine array_from_vector4_2 pure module subroutine array_from_vector3_1 (a, p) real(default), dimension(:), intent(out) :: a type(vector3_t), intent(in) :: p a = p%p end subroutine array_from_vector3_1 pure module subroutine array_from_vector3_2 (a, p) type(vector3_t), dimension(:), intent(in) :: p real(default), dimension(:,:), intent(out) :: a integer :: i forall (i=1:size(p)) a(:,i) = p(i)%p end forall end subroutine array_from_vector3_2 pure module subroutine vector4_from_array (p, a) type(vector4_t), intent(out) :: p real(default), dimension(:), intent(in) :: a p%p(0:3) = a end subroutine vector4_from_array pure module subroutine vector3_from_array (p, a) type(vector3_t), intent(out) :: p real(default), dimension(:), intent(in) :: a p%p(1:3) = a end subroutine vector3_from_array @ %def array_from_vector4 array_from_vector3 @ <>= public :: vector4 <>= pure module function vector4 (a) result (p) type(vector4_t) :: p real(default), intent(in), dimension(4) :: a end function vector4 <>= pure module function vector4 (a) result (p) type(vector4_t) :: p real(default), intent(in), dimension(4) :: a p%p = a end function vector4 @ %def vector4 @ <>= procedure :: to_pythia6 => vector4_to_pythia6 <>= pure module function vector4_to_pythia6 (vector4, m) result (p) real(double), dimension(1:5) :: p class(vector4_t), intent(in) :: vector4 real(default), intent(in), optional :: m end function vector4_to_pythia6 <>= pure module function vector4_to_pythia6 (vector4, m) result (p) real(double), dimension(1:5) :: p class(vector4_t), intent(in) :: vector4 real(default), intent(in), optional :: m p(1:3) = vector4%p(1:3) p(4) = vector4%p(0) if (present (m)) then p(5) = m else p(5) = vector4 ** 1 end if end function vector4_to_pythia6 @ %def vector4_to_pythia6 @ \subsection{Interface to [[c_prt]]} Transform the momentum of a [[c_prt]] object into a four-vector and vice versa: <>= interface assignment (=) module procedure vector4_from_c_prt, c_prt_from_vector4 end interface <>= pure module subroutine vector4_from_c_prt (p, c_prt) type(vector4_t), intent(out) :: p type(c_prt_t), intent(in) :: c_prt end subroutine vector4_from_c_prt pure module subroutine c_prt_from_vector4 (c_prt, p) type(c_prt_t), intent(out) :: c_prt type(vector4_t), intent(in) :: p end subroutine c_prt_from_vector4 <>= pure module subroutine vector4_from_c_prt (p, c_prt) type(vector4_t), intent(out) :: p type(c_prt_t), intent(in) :: c_prt p%p(0) = c_prt%pe p%p(1) = c_prt%px p%p(2) = c_prt%py p%p(3) = c_prt%pz end subroutine vector4_from_c_prt pure module subroutine c_prt_from_vector4 (c_prt, p) type(c_prt_t), intent(out) :: c_prt type(vector4_t), intent(in) :: p c_prt%pe = p%p(0) c_prt%px = p%p(1) c_prt%py = p%p(2) c_prt%pz = p%p(3) c_prt%p2 = p ** 2 end subroutine c_prt_from_vector4 @ %def vector4_from_c_prt c_prt_from_vector4 @ Initialize a [[c_prt_t]] object with the components of a four-vector as its kinematical entries. Compute the invariant mass, or use the optional mass-squared value instead. <>= public :: vector4_to_c_prt <>= elemental module function vector4_to_c_prt (p, p2) result (c_prt) type(c_prt_t) :: c_prt type(vector4_t), intent(in) :: p real(default), intent(in), optional :: p2 end function vector4_to_c_prt <>= elemental module function vector4_to_c_prt (p, p2) result (c_prt) type(c_prt_t) :: c_prt type(vector4_t), intent(in) :: p real(default), intent(in), optional :: p2 c_prt%pe = p%p(0) c_prt%px = p%p(1) c_prt%py = p%p(2) c_prt%pz = p%p(3) if (present (p2)) then c_prt%p2 = p2 else c_prt%p2 = p ** 2 end if end function vector4_to_c_prt @ %def vector4_to_c_prt @ \subsection{Angles} Return the angles in a canonical system. The angle $\phi$ is defined between $0\leq\phi<2\pi$. In degenerate cases, return zero. <>= public :: azimuthal_angle <>= interface azimuthal_angle module procedure vector3_azimuthal_angle module procedure vector4_azimuthal_angle end interface <>= elemental module function vector3_azimuthal_angle (p) result (phi) real(default) :: phi type(vector3_t), intent(in) :: p end function vector3_azimuthal_angle elemental module function vector4_azimuthal_angle (p) result (phi) real(default) :: phi type(vector4_t), intent(in) :: p end function vector4_azimuthal_angle <>= elemental module function vector3_azimuthal_angle (p) result (phi) real(default) :: phi type(vector3_t), intent(in) :: p if (any (abs (p%p(1:2)) > 0)) then phi = atan2(p%p(2), p%p(1)) if (phi < 0) phi = phi + twopi else phi = 0 end if end function vector3_azimuthal_angle elemental module function vector4_azimuthal_angle (p) result (phi) real(default) :: phi type(vector4_t), intent(in) :: p phi = vector3_azimuthal_angle (space_part (p)) end function vector4_azimuthal_angle @ %def azimuthal_angle @ Azimuthal angle in degrees <>= public :: azimuthal_angle_deg <>= interface azimuthal_angle_deg module procedure vector3_azimuthal_angle_deg module procedure vector4_azimuthal_angle_deg end interface <>= elemental module function vector3_azimuthal_angle_deg (p) result (phi) real(default) :: phi type(vector3_t), intent(in) :: p end function vector3_azimuthal_angle_deg elemental module function vector4_azimuthal_angle_deg (p) result (phi) real(default) :: phi type(vector4_t), intent(in) :: p end function vector4_azimuthal_angle_deg <>= elemental module function vector3_azimuthal_angle_deg (p) result (phi) real(default) :: phi type(vector3_t), intent(in) :: p phi = vector3_azimuthal_angle (p) / degree end function vector3_azimuthal_angle_deg elemental module function vector4_azimuthal_angle_deg (p) result (phi) real(default) :: phi type(vector4_t), intent(in) :: p phi = vector4_azimuthal_angle (p) / degree end function vector4_azimuthal_angle_deg @ %def azimuthal_angle_deg @ The azimuthal distance of two vectors. This is the difference of the azimuthal angles, but cannot be larger than $\pi$: The result is between $-\pi<\Delta\phi\leq\pi$. <>= public :: azimuthal_distance <>= interface azimuthal_distance module procedure vector3_azimuthal_distance module procedure vector4_azimuthal_distance end interface <>= elemental module function vector3_azimuthal_distance (p, q) result (dphi) real(default) :: dphi type(vector3_t), intent(in) :: p,q end function vector3_azimuthal_distance elemental module function vector4_azimuthal_distance (p, q) result (dphi) real(default) :: dphi type(vector4_t), intent(in) :: p,q end function vector4_azimuthal_distance <>= elemental module function vector3_azimuthal_distance (p, q) result (dphi) real(default) :: dphi type(vector3_t), intent(in) :: p,q dphi = vector3_azimuthal_angle (q) - vector3_azimuthal_angle (p) if (dphi <= -pi) then dphi = dphi + twopi else if (dphi > pi) then dphi = dphi - twopi end if end function vector3_azimuthal_distance elemental module function vector4_azimuthal_distance (p, q) result (dphi) real(default) :: dphi type(vector4_t), intent(in) :: p,q dphi = vector3_azimuthal_distance & (space_part (p), space_part (q)) end function vector4_azimuthal_distance @ %def azimuthal_distance @ The same in degrees: <>= public :: azimuthal_distance_deg <>= interface azimuthal_distance_deg module procedure vector3_azimuthal_distance_deg module procedure vector4_azimuthal_distance_deg end interface <>= elemental module function vector3_azimuthal_distance_deg (p, q) result (dphi) real(default) :: dphi type(vector3_t), intent(in) :: p,q end function vector3_azimuthal_distance_deg elemental module function vector4_azimuthal_distance_deg (p, q) result (dphi) real(default) :: dphi type(vector4_t), intent(in) :: p,q end function vector4_azimuthal_distance_deg <>= elemental module function vector3_azimuthal_distance_deg (p, q) result (dphi) real(default) :: dphi type(vector3_t), intent(in) :: p,q dphi = vector3_azimuthal_distance (p, q) / degree end function vector3_azimuthal_distance_deg elemental module function vector4_azimuthal_distance_deg (p, q) result (dphi) real(default) :: dphi type(vector4_t), intent(in) :: p,q dphi = vector4_azimuthal_distance (p, q) / degree end function vector4_azimuthal_distance_deg @ %def azimuthal_distance_deg @ The polar angle is defined $0\leq\theta\leq\pi$. Note that [[ATAN2]] has the reversed order of arguments: [[ATAN2(Y,X)]]. Here, $x$ is the 3-component while $y$ is the transverse momentum which is always nonnegative. Therefore, the result is nonnegative as well. <>= public :: polar_angle <>= interface polar_angle module procedure polar_angle_vector3 module procedure polar_angle_vector4 end interface <>= elemental module function polar_angle_vector3 (p) result (theta) real(default) :: theta type(vector3_t), intent(in) :: p end function polar_angle_vector3 elemental module function polar_angle_vector4 (p) result (theta) real(default) :: theta type(vector4_t), intent(in) :: p end function polar_angle_vector4 <>= elemental module function polar_angle_vector3 (p) result (theta) real(default) :: theta type(vector3_t), intent(in) :: p if (any (abs (p%p) > 0)) then theta = atan2 (sqrt(p%p(1)**2 + p%p(2)**2), p%p(3)) else theta = 0 end if end function polar_angle_vector3 elemental module function polar_angle_vector4 (p) result (theta) real(default) :: theta type(vector4_t), intent(in) :: p theta = polar_angle (space_part (p)) end function polar_angle_vector4 @ %def polar_angle @ This is the cosine of the polar angle: $-1\leq\cos\theta\leq 1$. <>= public :: polar_angle_ct <>= interface polar_angle_ct module procedure polar_angle_ct_vector3 module procedure polar_angle_ct_vector4 end interface <>= elemental module function polar_angle_ct_vector3 (p) result (ct) real(default) :: ct type(vector3_t), intent(in) :: p end function polar_angle_ct_vector3 elemental module function polar_angle_ct_vector4 (p) result (ct) real(default) :: ct type(vector4_t), intent(in) :: p end function polar_angle_ct_vector4 <>= elemental module function polar_angle_ct_vector3 (p) result (ct) real(default) :: ct type(vector3_t), intent(in) :: p if (any (abs (p%p) > 0)) then ct = p%p(3) / p**1 else ct = 1 end if end function polar_angle_ct_vector3 elemental module function polar_angle_ct_vector4 (p) result (ct) real(default) :: ct type(vector4_t), intent(in) :: p ct = polar_angle_ct (space_part (p)) end function polar_angle_ct_vector4 @ %def polar_angle_ct @ The polar angle in degrees. <>= public :: polar_angle_deg <>= interface polar_angle_deg module procedure polar_angle_deg_vector3 module procedure polar_angle_deg_vector4 end interface <>= elemental module function polar_angle_deg_vector3 (p) result (theta) real(default) :: theta type(vector3_t), intent(in) :: p end function polar_angle_deg_vector3 elemental module function polar_angle_deg_vector4 (p) result (theta) real(default) :: theta type(vector4_t), intent(in) :: p end function polar_angle_deg_vector4 <>= elemental module function polar_angle_deg_vector3 (p) result (theta) real(default) :: theta type(vector3_t), intent(in) :: p theta = polar_angle (p) / degree end function polar_angle_deg_vector3 elemental module function polar_angle_deg_vector4 (p) result (theta) real(default) :: theta type(vector4_t), intent(in) :: p theta = polar_angle (p) / degree end function polar_angle_deg_vector4 @ %def polar_angle_deg @ This is the angle enclosed between two three-momenta. If one of the momenta is zero, we return an angle of zero. The range of the result is $0\leq\theta\leq\pi$. If there is only one argument, take the positive $z$ axis as reference. <>= public :: enclosed_angle <>= interface enclosed_angle module procedure enclosed_angle_vector3 module procedure enclosed_angle_vector4 end interface <>= elemental module function enclosed_angle_vector3 (p, q) result (theta) real(default) :: theta type(vector3_t), intent(in) :: p, q end function enclosed_angle_vector3 elemental module function enclosed_angle_vector4 (p, q) result (theta) real(default) :: theta type(vector4_t), intent(in) :: p, q end function enclosed_angle_vector4 <>= elemental module function enclosed_angle_vector3 (p, q) result (theta) real(default) :: theta type(vector3_t), intent(in) :: p, q theta = acos (enclosed_angle_ct (p, q)) end function enclosed_angle_vector3 elemental module function enclosed_angle_vector4 (p, q) result (theta) real(default) :: theta type(vector4_t), intent(in) :: p, q theta = enclosed_angle (space_part (p), space_part (q)) end function enclosed_angle_vector4 @ %def enclosed_angle @ The cosine of the enclosed angle. <>= public :: enclosed_angle_ct <>= interface enclosed_angle_ct module procedure enclosed_angle_ct_vector3 module procedure enclosed_angle_ct_vector4 end interface <>= elemental module function enclosed_angle_ct_vector3 (p, q) result (ct) real(default) :: ct type(vector3_t), intent(in) :: p, q end function enclosed_angle_ct_vector3 elemental module function enclosed_angle_ct_vector4 (p, q) result (ct) real(default) :: ct type(vector4_t), intent(in) :: p, q end function enclosed_angle_ct_vector4 <>= elemental module function enclosed_angle_ct_vector3 (p, q) result (ct) real(default) :: ct type(vector3_t), intent(in) :: p, q if (any (abs (p%p) > 0) .and. any (abs (q%p) > 0)) then ct = p*q / (p**1 * q**1) if (ct>1) then ct = 1 else if (ct<-1) then ct = -1 end if else ct = 1 end if end function enclosed_angle_ct_vector3 elemental module function enclosed_angle_ct_vector4 (p, q) result (ct) real(default) :: ct type(vector4_t), intent(in) :: p, q ct = enclosed_angle_ct (space_part (p), space_part (q)) end function enclosed_angle_ct_vector4 @ %def enclosed_angle_ct @ The enclosed angle in degrees. <>= public :: enclosed_angle_deg <>= interface enclosed_angle_deg module procedure enclosed_angle_deg_vector3 module procedure enclosed_angle_deg_vector4 end interface <>= elemental module function enclosed_angle_deg_vector3 (p, q) result (theta) real(default) :: theta type(vector3_t), intent(in) :: p, q end function enclosed_angle_deg_vector3 elemental module function enclosed_angle_deg_vector4 (p, q) result (theta) real(default) :: theta type(vector4_t), intent(in) :: p, q end function enclosed_angle_deg_vector4 <>= elemental module function enclosed_angle_deg_vector3 (p, q) result (theta) real(default) :: theta type(vector3_t), intent(in) :: p, q theta = enclosed_angle (p, q) / degree end function enclosed_angle_deg_vector3 elemental module function enclosed_angle_deg_vector4 (p, q) result (theta) real(default) :: theta type(vector4_t), intent(in) :: p, q theta = enclosed_angle (p, q) / degree end function enclosed_angle_deg_vector4 @ %def enclosed_angle @ The polar angle of the first momentum w.r.t.\ the second momentum, evaluated in the rest frame of the second momentum. If the second four-momentum is not timelike, return zero. <>= public :: enclosed_angle_rest_frame public :: enclosed_angle_ct_rest_frame public :: enclosed_angle_deg_rest_frame <>= interface enclosed_angle_rest_frame module procedure enclosed_angle_rest_frame_vector4 end interface interface enclosed_angle_ct_rest_frame module procedure enclosed_angle_ct_rest_frame_vector4 end interface interface enclosed_angle_deg_rest_frame module procedure enclosed_angle_deg_rest_frame_vector4 end interface <>= elemental module function enclosed_angle_rest_frame_vector4 (p, q) result (theta) type(vector4_t), intent(in) :: p, q real(default) :: theta end function enclosed_angle_rest_frame_vector4 elemental module function enclosed_angle_ct_rest_frame_vector4 (p, q) result (ct) type(vector4_t), intent(in) :: p, q real(default) :: ct end function enclosed_angle_ct_rest_frame_vector4 elemental module function enclosed_angle_deg_rest_frame_vector4 (p, q) & result (theta) type(vector4_t), intent(in) :: p, q real(default) :: theta end function enclosed_angle_deg_rest_frame_vector4 <>= elemental module function enclosed_angle_rest_frame_vector4 (p, q) result (theta) type(vector4_t), intent(in) :: p, q real(default) :: theta theta = acos (enclosed_angle_ct_rest_frame (p, q)) end function enclosed_angle_rest_frame_vector4 elemental module function enclosed_angle_ct_rest_frame_vector4 (p, q) result (ct) type(vector4_t), intent(in) :: p, q real(default) :: ct if (invariant_mass(q) > 0) then ct = enclosed_angle_ct ( & space_part (boost(-q, invariant_mass (q)) * p), & space_part (q)) else ct = 1 end if end function enclosed_angle_ct_rest_frame_vector4 elemental module function enclosed_angle_deg_rest_frame_vector4 (p, q) & result (theta) type(vector4_t), intent(in) :: p, q real(default) :: theta theta = enclosed_angle_rest_frame (p, q) / degree end function enclosed_angle_deg_rest_frame_vector4 @ %def enclosed_angle_rest_frame @ %def enclosed_angle_ct_rest_frame @ %def enclosed_angle_deg_rest_frame @ \subsection{More kinematical functions (some redundant)} The scalar transverse momentum (assuming the $z$ axis is longitudinal) <>= public :: transverse_part <>= interface transverse_part module procedure transverse_part_vector4_beam_axis module procedure transverse_part_vector4_vector4 end interface <>= elemental module function transverse_part_vector4_beam_axis (p) result (pT) real(default) :: pT type(vector4_t), intent(in) :: p end function transverse_part_vector4_beam_axis elemental module function transverse_part_vector4_vector4 (p1, p2) result (pT) real(default) :: pT type(vector4_t), intent(in) :: p1, p2 end function transverse_part_vector4_vector4 <>= elemental module function transverse_part_vector4_beam_axis (p) result (pT) real(default) :: pT type(vector4_t), intent(in) :: p pT = sqrt(p%p(1)**2 + p%p(2)**2) end function transverse_part_vector4_beam_axis elemental module function transverse_part_vector4_vector4 (p1, p2) result (pT) real(default) :: pT type(vector4_t), intent(in) :: p1, p2 real(default) :: p1_norm, p2_norm, p1p2, pT2 p1_norm = space_part_norm(p1)**2 p2_norm = space_part_norm(p2)**2 ! p1p2 = p1%p(1:3)*p2%p(1:3) p1p2 = vector4_get_space_part(p1) * vector4_get_space_part(p2) pT2 = (p1_norm*p2_norm - p1p2)/p1_norm pT = sqrt (pT2) end function transverse_part_vector4_vector4 @ %def transverse_part @ The scalar longitudinal momentum (assuming the $z$ axis is longitudinal). Identical to [[momentum_z_component]]. <>= public :: longitudinal_part <>= interface longitudinal_part module procedure longitudinal_part_vector4 end interface <>= elemental module function longitudinal_part_vector4 (p) result (pL) real(default) :: pL type(vector4_t), intent(in) :: p end function longitudinal_part_vector4 <>= elemental module function longitudinal_part_vector4 (p) result (pL) real(default) :: pL type(vector4_t), intent(in) :: p pL = p%p(3) end function longitudinal_part_vector4 @ %def longitudinal_part @ Absolute value of three-momentum <>= public :: space_part_norm <>= interface space_part_norm module procedure space_part_norm_vector4 end interface <>= elemental module function space_part_norm_vector4 (p) result (p3) real(default) :: p3 type(vector4_t), intent(in) :: p end function space_part_norm_vector4 <>= elemental module function space_part_norm_vector4 (p) result (p3) real(default) :: p3 type(vector4_t), intent(in) :: p p3 = sqrt (p%p(1)**2 + p%p(2)**2 + p%p(3)**2) end function space_part_norm_vector4 @ %def momentum @ The energy (the zeroth component) <>= public :: energy <>= interface energy module procedure energy_vector4 module procedure energy_vector3 module procedure energy_real end interface <>= elemental module function energy_vector4 (p) result (E) real(default) :: E type(vector4_t), intent(in) :: p end function energy_vector4 elemental module function energy_vector3 (p, mass) result (E) real(default) :: E type(vector3_t), intent(in) :: p real(default), intent(in), optional :: mass end function energy_vector3 elemental module function energy_real (p, mass) result (E) real(default) :: E real(default), intent(in) :: p real(default), intent(in), optional :: mass end function energy_real <>= elemental module function energy_vector4 (p) result (E) real(default) :: E type(vector4_t), intent(in) :: p E = p%p(0) end function energy_vector4 @ Alternative: The energy corresponding to a given momentum and mass. If the mass is omitted, it is zero <>= elemental module function energy_vector3 (p, mass) result (E) real(default) :: E type(vector3_t), intent(in) :: p real(default), intent(in), optional :: mass if (present (mass)) then E = sqrt (p**2 + mass**2) else E = p**1 end if end function energy_vector3 elemental module function energy_real (p, mass) result (E) real(default) :: E real(default), intent(in) :: p real(default), intent(in), optional :: mass if (present (mass)) then E = sqrt (p**2 + mass**2) else E = abs (p) end if end function energy_real @ %def energy @ The invariant mass of four-momenta. Zero for lightlike, negative for spacelike momenta. <>= public :: invariant_mass <>= interface invariant_mass module procedure invariant_mass_vector4 end interface <>= elemental module function invariant_mass_vector4 (p) result (m) real(default) :: m type(vector4_t), intent(in) :: p end function invariant_mass_vector4 <>= elemental module function invariant_mass_vector4 (p) result (m) real(default) :: m type(vector4_t), intent(in) :: p real(default) :: msq msq = p*p if (msq >= 0) then m = sqrt (msq) else m = - sqrt (abs (msq)) end if end function invariant_mass_vector4 @ %def invariant_mass @ The invariant mass squared. Zero for lightlike, negative for spacelike momenta. <>= public :: invariant_mass_squared <>= interface invariant_mass_squared module procedure invariant_mass_squared_vector4 end interface <>= elemental module function invariant_mass_squared_vector4 (p) result (msq) real(default) :: msq type(vector4_t), intent(in) :: p end function invariant_mass_squared_vector4 <>= elemental module function invariant_mass_squared_vector4 (p) result (msq) real(default) :: msq type(vector4_t), intent(in) :: p msq = p*p end function invariant_mass_squared_vector4 @ %def invariant_mass_squared @ The transverse mass. If the mass squared is negative, this value also is negative. <>= public :: transverse_mass <>= interface transverse_mass module procedure transverse_mass_vector4 end interface <>= elemental module function transverse_mass_vector4 (p) result (m) real(default) :: m type(vector4_t), intent(in) :: p end function transverse_mass_vector4 <>= elemental module function transverse_mass_vector4 (p) result (m) real(default) :: m type(vector4_t), intent(in) :: p real(default) :: msq msq = p%p(0)**2 - p%p(1)**2 - p%p(2)**2 if (msq >= 0) then m = sqrt (msq) else m = - sqrt (abs (msq)) end if end function transverse_mass_vector4 @ %def transverse_mass @ The rapidity (defined if particle is massive or $p_\perp>0$) <>= public :: rapidity <>= interface rapidity module procedure rapidity_vector4 end interface <>= elemental module function rapidity_vector4 (p) result (y) real(default) :: y type(vector4_t), intent(in) :: p end function rapidity_vector4 <>= elemental module function rapidity_vector4 (p) result (y) real(default) :: y type(vector4_t), intent(in) :: p y = .5 * log( (energy (p) + longitudinal_part (p)) & & /(energy (p) - longitudinal_part (p))) end function rapidity_vector4 @ %def rapidity @ The pseudorapidity (defined if $p_\perp>0$) <>= public :: pseudorapidity <>= interface pseudorapidity module procedure pseudorapidity_vector4 end interface <>= elemental module function pseudorapidity_vector4 (p) result (eta) real(default) :: eta type(vector4_t), intent(in) :: p end function pseudorapidity_vector4 <>= elemental module function pseudorapidity_vector4 (p) result (eta) real(default) :: eta type(vector4_t), intent(in) :: p eta = -log( tan (.5 * polar_angle (p))) end function pseudorapidity_vector4 @ %def pseudorapidity @ The rapidity distance (defined if both $p_\perp>0$) <>= public :: rapidity_distance <>= interface rapidity_distance module procedure rapidity_distance_vector4 end interface <>= elemental module function rapidity_distance_vector4 (p, q) result (dy) type(vector4_t), intent(in) :: p, q real(default) :: dy end function rapidity_distance_vector4 <>= elemental module function rapidity_distance_vector4 (p, q) result (dy) type(vector4_t), intent(in) :: p, q real(default) :: dy dy = rapidity (q) - rapidity (p) end function rapidity_distance_vector4 @ %def rapidity_distance @ The pseudorapidity distance (defined if both $p_\perp>0$) <>= public :: pseudorapidity_distance <>= interface pseudorapidity_distance module procedure pseudorapidity_distance_vector4 end interface <>= elemental module function pseudorapidity_distance_vector4 (p, q) result (deta) real(default) :: deta type(vector4_t), intent(in) :: p, q end function pseudorapidity_distance_vector4 <>= elemental module function pseudorapidity_distance_vector4 (p, q) result (deta) real(default) :: deta type(vector4_t), intent(in) :: p, q deta = pseudorapidity (q) - pseudorapidity (p) end function pseudorapidity_distance_vector4 @ %def pseudorapidity_distance @ The distance on the $\eta-\phi$ cylinder: <>= public :: eta_phi_distance <>= interface eta_phi_distance module procedure eta_phi_distance_vector4 end interface <>= elemental module function eta_phi_distance_vector4 (p, q) result (dr) type(vector4_t), intent(in) :: p, q real(default) :: dr end function eta_phi_distance_vector4 <>= elemental module function eta_phi_distance_vector4 (p, q) result (dr) type(vector4_t), intent(in) :: p, q real(default) :: dr dr = sqrt ( & pseudorapidity_distance (p, q)**2 & + azimuthal_distance (p, q)**2) end function eta_phi_distance_vector4 @ %def eta_phi_distance @ \subsection{Lorentz transformations} <>= public :: lorentz_transformation_t <>= type :: lorentz_transformation_t private real(default), dimension(0:3, 0:3) :: L contains <> end type lorentz_transformation_t @ %def lorentz_transformation_t @ Output: <>= public :: lorentz_transformation_write <>= procedure :: write => lorentz_transformation_write <>= module subroutine lorentz_transformation_write (L, unit, testflag, ultra) class(lorentz_transformation_t), intent(in) :: L integer, intent(in), optional :: unit logical, intent(in), optional :: testflag, ultra end subroutine lorentz_transformation_write <>= module subroutine lorentz_transformation_write (L, unit, testflag, ultra) class(lorentz_transformation_t), intent(in) :: L integer, intent(in), optional :: unit logical, intent(in), optional :: testflag, ultra integer :: u, i logical :: ult character(len=7) :: fmt ult = .false.; if (present (ultra)) ult = ultra if (ult) then call pac_fmt (fmt, FMT_19, FMT_11, ultra) else call pac_fmt (fmt, FMT_19, FMT_13, testflag) end if u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A,3(1x," // fmt // "))") "L00 = ", L%L(0,0) write (u, "(1x,A,3(1x," // fmt // "))") "L0j = ", L%L(0,1:3) do i = 1, 3 write (u, "(1x,A,I0,A,3(1x," // fmt // "))") & "L", i, "0 = ", L%L(i,0) write (u, "(1x,A,I0,A,3(1x," // fmt // "))") & "L", i, "j = ", L%L(i,1:3) end do end subroutine lorentz_transformation_write @ %def lorentz_transformation_write @ Extract all components: <>= public :: lorentz_transformation_get_components <>= pure module function lorentz_transformation_get_components (L) result (a) type(lorentz_transformation_t), intent(in) :: L real(default), dimension(0:3,0:3) :: a end function lorentz_transformation_get_components <>= pure module function lorentz_transformation_get_components (L) result (a) type(lorentz_transformation_t), intent(in) :: L real(default), dimension(0:3,0:3) :: a a = L%L end function lorentz_transformation_get_components @ %def lorentz_transformation_get_components @ \subsection{Functions of Lorentz transformations} For the inverse, we make use of the fact that $\Lambda^{\mu\nu}\Lambda_{\mu\rho}=\delta^\nu_\rho$. So, lowering the indices and transposing is sufficient. <>= public :: inverse <>= interface inverse module procedure lorentz_transformation_inverse end interface <>= elemental module function lorentz_transformation_inverse (L) result (IL) type(lorentz_transformation_t) :: IL type(lorentz_transformation_t), intent(in) :: L end function lorentz_transformation_inverse <>= elemental module function lorentz_transformation_inverse (L) result (IL) type(lorentz_transformation_t) :: IL type(lorentz_transformation_t), intent(in) :: L IL%L(0,0) = L%L(0,0) IL%L(0,1:) = -L%L(1:,0) IL%L(1:,0) = -L%L(0,1:) IL%L(1:,1:) = transpose(L%L(1:,1:)) end function lorentz_transformation_inverse @ %def lorentz_transformation_inverse @ %def inverse @ \subsection{Invariants} These are used below. The first array index is varying fastest in [[FORTRAN]]; therefore the extra minus in the odd-rank tensor epsilon. <>= integer, dimension(3,3), parameter :: delta_three = & & reshape( source = [ 1,0,0, 0,1,0, 0,0,1 ], & & shape = [3,3] ) integer, dimension(3,3,3), parameter :: epsilon_three = & & reshape( source = [ 0, 0,0, 0,0,-1, 0,1,0, & & 0, 0,1, 0,0, 0, -1,0,0, & & 0,-1,0, 1,0, 0, 0,0,0 ],& & shape = [3,3,3] ) @ %def delta_three epsilon_three @ This could be of some use: <>= public :: identity <>= type(lorentz_transformation_t), parameter :: & & identity = & & lorentz_transformation_t ( & & reshape( source = [ one, zero, zero, zero, & & zero, one, zero, zero, & & zero, zero, one, zero, & & zero, zero, zero, one ],& & shape = [4,4] ) ) @ %def identity <>= public :: space_reflection <>= type(lorentz_transformation_t), parameter :: & & space_reflection = & & lorentz_transformation_t ( & & reshape( source = [ one, zero, zero, zero, & & zero,-one, zero, zero, & & zero, zero,-one, zero, & & zero, zero, zero,-one ],& & shape = [4,4] ) ) @ %def space_reflection @ Builds a unit vector orthogal to the input vector in the xy-plane. <>= public :: create_orthogonal <>= module function create_orthogonal (p_in) result (p_out) type(vector3_t), intent(in) :: p_in type(vector3_t) :: p_out end function create_orthogonal <>= module function create_orthogonal (p_in) result (p_out) type(vector3_t), intent(in) :: p_in type(vector3_t) :: p_out real(default) :: ab ab = sqrt (p_in%p(1)**2 + p_in%p(2)**2) if (abs (ab) < eps0) then p_out%p(1) = 1 p_out%p(2) = 0 p_out%p(3) = 0 else p_out%p(1) = p_in%p(2) p_out%p(2) = -p_in%p(1) p_out%p(3) = 0 p_out = p_out / ab end if end function create_orthogonal @ %def create_orthogonal @ <>= public :: create_unit_vector <>= module function create_unit_vector (p_in) result (p_out) type(vector4_t), intent(in) :: p_in type(vector3_t) :: p_out end function create_unit_vector <>= module function create_unit_vector (p_in) result (p_out) type(vector4_t), intent(in) :: p_in type(vector3_t) :: p_out p_out%p = p_in%p(1:3) / space_part_norm (p_in) end function create_unit_vector @ %def create_unit_vector @ <>= public :: normalize <>= module function normalize(p) result (p_norm) type(vector3_t) :: p_norm type(vector3_t), intent(in) :: p end function normalize <>= module function normalize(p) result (p_norm) type(vector3_t) :: p_norm type(vector3_t), intent(in) :: p real(default) :: abs abs = sqrt (p%p(1)**2 + p%p(2)**2 + p%p(3)**2) p_norm = p / abs end function normalize @ %def normalize @ Computes the invariant mass of the momenta sum given by the indices in [[i_res_born]] and the optional argument [[i_emitter]]. <>= public :: compute_resonance_mass <>= pure module function compute_resonance_mass (p, i_res_born, i_gluon) result (m) real(default) :: m type(vector4_t), intent(in), dimension(:) :: p integer, intent(in), dimension(:) :: i_res_born integer, intent(in), optional :: i_gluon end function compute_resonance_mass <>= pure module function compute_resonance_mass (p, i_res_born, i_gluon) result (m) real(default) :: m type(vector4_t), intent(in), dimension(:) :: p integer, intent(in), dimension(:) :: i_res_born integer, intent(in), optional :: i_gluon type(vector4_t) :: p_res p_res = get_resonance_momentum (p, i_res_born, i_gluon) m = p_res**1 end function compute_resonance_mass @ %def compute_resonance_mass @ <>= public :: get_resonance_momentum <>= pure module function get_resonance_momentum & (p, i_res_born, i_gluon) result (p_res) type(vector4_t) :: p_res type(vector4_t), intent(in), dimension(:) :: p integer, intent(in), dimension(:) :: i_res_born integer, intent(in), optional :: i_gluon end function get_resonance_momentum <>= pure module function get_resonance_momentum & (p, i_res_born, i_gluon) result (p_res) type(vector4_t) :: p_res type(vector4_t), intent(in), dimension(:) :: p integer, intent(in), dimension(:) :: i_res_born integer, intent(in), optional :: i_gluon integer :: i p_res = vector4_null do i = 1, size (i_res_born) p_res = p_res + p (i_res_born(i)) end do if (present (i_gluon)) p_res = p_res + p (i_gluon) end function get_resonance_momentum @ %def get_resonance_momentum @ <>= public :: create_two_particle_decay <>= module function create_two_particle_decay (s, p1, p2) result (p_rest) type(vector4_t), dimension(3) :: p_rest real(default), intent(in) :: s type(vector4_t), intent(in) :: p1, p2 end function create_two_particle_decay <>= module function create_two_particle_decay (s, p1, p2) result (p_rest) type(vector4_t), dimension(3) :: p_rest real(default), intent(in) :: s type(vector4_t), intent(in) :: p1, p2 real(default) :: m1_sq, m2_sq real(default) :: E1, E2, p m1_sq = p1**2; m2_sq = p2**2 p = sqrt (lambda (s, m1_sq, m2_sq)) / (two * sqrt (s)) E1 = sqrt (m1_sq + p**2); E2 = sqrt (m2_sq + p**2) p_rest(1)%p = [sqrt (s), zero, zero, zero] p_rest(2)%p(0) = E1 p_rest(2)%p(1:3) = p * p1%p(1:3) / space_part_norm (p1) p_rest(3)%p(0) = E2; p_rest(3)%p(1:3) = -p_rest(2)%p(1:3) end function create_two_particle_decay @ %def create_two_particle_decay @ This function creates a phase-space point for a $1 \to 3$ decay in the decaying particle's rest frame. There are three rest frames for this system, corresponding to $s$-, $t$,- and $u$-channel momentum exchange, also referred to as Gottfried-Jackson frames. Below, we choose the momentum with index 1 to be aligned along the $z$-axis. We then have \begin{align*} s_1 &= \left(p_1 + p_2\right)^2, \\ s_2 &= \left(p_2 + p_3\right)^2, \\ s_3 &= \left(p_1 + p_3\right)^2, \\ s_1 + s_2 + s_3 &= s + m_1^2 + m_2^2 + m_3^2. \end{align*} From these we can construct \begin{align*} E_1^{R23} = \frac{s - s_2 - m_1^2}{2\sqrt{s_2}} &\quad P_1^{R23} = \frac{\lambda^{1/2}(s, s_2, m_1^2)}{2\sqrt{s_2}},\\ E_2^{R23} = \frac{s_2 + m_2^2 - m_3^2}{2\sqrt{s_2}} &\quad P_2^{R23} = \frac{\lambda^{1/2}(s_2, m_2^2, m_3^2)}{2\sqrt{s_2}},\\ E_3^{R23} = \frac{s_2 + m_3^2 - m_2^2}{2\sqrt{s_2}} &\quad P_3^{R23} = P_2^{R23}, \end{align*} where $R23$ denotes the Gottfried-Jackson frame of our choice. Finally, the scattering angle $\theta_{12}^{R23}$ between momentum $1$ and $2$ can be determined to be \begin{equation*} \cos\theta_{12}^{R23} = \frac{(s - s_2 - m_1^2)(s_2 + m_2^2 - m_3^2) + 2s_2 (m_1^2 + m_2^2 - s_1)} {\lambda^{1/2}(s, s_2, m_1^2) \lambda^{1/2}(s_2, m_2^2, m_3^2)} \end{equation*} <>= public :: create_three_particle_decay <>= module function create_three_particle_decay (p1, p2, p3) result (p_rest) type(vector4_t), dimension(4) :: p_rest type(vector4_t), intent(in) :: p1, p2, p3 end function create_three_particle_decay <>= module function create_three_particle_decay (p1, p2, p3) result (p_rest) type(vector4_t), dimension(4) :: p_rest type(vector4_t), intent(in) :: p1, p2, p3 real(default) :: E1, E2, E3 real(default) :: pr1, pr2, pr3 real(default) :: s, s1, s2, s3 real(default) :: m1_sq, m2_sq, m3_sq real(default) :: cos_theta_12 type(vector3_t) :: v3_unit type(lorentz_transformation_t) :: rot m1_sq = p1**2 m2_sq = p2**2 m3_sq = p3**2 s1 = (p1 + p2)**2 s2 = (p2 + p3)**2 s3 = (p3 + p1)**2 s = s1 + s2 + s3 - m1_sq - m2_sq - m3_sq E1 = (s - s2 - m1_sq) / (two * sqrt (s2)) E2 = (s2 + m2_sq - m3_sq) / (two * sqrt (s2)) E3 = (s2 + m3_sq - m2_sq) / (two * sqrt (s2)) pr1 = sqrt (lambda (s, s2, m1_sq)) / (two * sqrt (s2)) pr2 = sqrt (lambda (s2, m2_sq, m3_sq)) / (two * sqrt(s2)) pr3 = pr2 cos_theta_12 = ((s - s2 - m1_sq) * (s2 + m2_sq - m3_sq) + two * s2 * (m1_sq + m2_sq - s1)) / & sqrt (lambda (s, s2, m1_sq) * lambda (s2, m2_sq, m3_sq)) v3_unit%p = [zero, zero, one] p_rest(1)%p(0) = E1 p_rest(1)%p(1:3) = v3_unit%p * pr1 p_rest(2)%p(0) = E2 p_rest(2)%p(1:3) = v3_unit%p * pr2 p_rest(3)%p(0) = E3 p_rest(3)%p(1:3) = v3_unit%p * pr3 p_rest(4)%p(0) = (s + s2 - m1_sq) / (2 * sqrt (s2)) p_rest(4)%p(1:3) = - p_rest(1)%p(1:3) rot = rotation (cos_theta_12, sqrt (one - cos_theta_12**2), 2) p_rest(2) = rot * p_rest(2) p_rest(3)%p(1:3) = - p_rest(2)%p(1:3) end function create_three_particle_decay @ %def create_three_particle_decay @ <>= public :: evaluate_one_to_two_splitting_special <>= abstract interface subroutine evaluate_one_to_two_splitting_special (p_origin, & p1_in, p2_in, p1_out, p2_out, msq_in, jac) import type(vector4_t), intent(in) :: p_origin type(vector4_t), intent(in) :: p1_in, p2_in type(vector4_t), intent(inout) :: p1_out, p2_out real(default), intent(in), optional :: msq_in real(default), intent(inout), optional :: jac end subroutine evaluate_one_to_two_splitting_special end interface @ %def evaluate_one_to_two_splitting_special @ <>= public :: generate_on_shell_decay <>= recursive module subroutine generate_on_shell_decay (p_dec, & p_in, p_out, i_real, msq_in, jac, evaluate_special) type(vector4_t), intent(in) :: p_dec type(vector4_t), intent(in), dimension(:) :: p_in type(vector4_t), intent(inout), dimension(:) :: p_out integer, intent(in) :: i_real real(default), intent(in), optional :: msq_in real(default), intent(inout), optional :: jac procedure(evaluate_one_to_two_splitting_special), intent(in), & pointer, optional :: evaluate_special end subroutine generate_on_shell_decay <>= recursive module subroutine generate_on_shell_decay (p_dec, & p_in, p_out, i_real, msq_in, jac, evaluate_special) type(vector4_t), intent(in) :: p_dec type(vector4_t), intent(in), dimension(:) :: p_in type(vector4_t), intent(inout), dimension(:) :: p_out integer, intent(in) :: i_real real(default), intent(in), optional :: msq_in real(default), intent(inout), optional :: jac procedure(evaluate_one_to_two_splitting_special), intent(in), & pointer, optional :: evaluate_special type(vector4_t) :: p_dec_new integer :: n_recoil n_recoil = size (p_in) - 1 if (n_recoil > 1) then if (present (evaluate_special)) then call evaluate_special (p_dec, p_in(1), sum (p_in (2 : n_recoil + 1)), & p_out(i_real), p_dec_new) call generate_on_shell_decay (p_dec_new, p_in (2 : ), p_out, & i_real + 1, msq_in, jac, evaluate_special) else call evaluate_one_to_two_splitting (p_dec, p_in(1), & sum (p_in (2 : n_recoil + 1)), p_out(i_real), p_dec_new, msq_in, jac) call generate_on_shell_decay (p_dec_new, p_in (2 : ), p_out, & i_real + 1, msq_in, jac) end if else call evaluate_one_to_two_splitting (p_dec, p_in(1), p_in(2), & p_out(i_real), p_out(i_real + 1), msq_in, jac) end if end subroutine generate_on_shell_decay subroutine evaluate_one_to_two_splitting (p_origin, & p1_in, p2_in, p1_out, p2_out, msq_in, jac) type(vector4_t), intent(in) :: p_origin type(vector4_t), intent(in) :: p1_in, p2_in type(vector4_t), intent(inout) :: p1_out, p2_out real(default), intent(in), optional :: msq_in real(default), intent(inout), optional :: jac type(lorentz_transformation_t) :: L type(vector4_t) :: p1_rest, p2_rest real(default) :: m, msq, msq1, msq2 real(default) :: E1, E2, p real(default) :: lda, rlda_soft call get_rest_frame (p1_in, p2_in, p1_rest, p2_rest) msq = p_origin**2; m = sqrt(msq) msq1 = p1_in**2; msq2 = p2_in**2 lda = lambda (msq, msq1, msq2) if (lda < zero) then print *, 'Encountered lambda < 0 in 1 -> 2 splitting! ' print *, 'lda: ', lda print *, 'm: ', m, 'msq: ', msq print *, 'm1: ', sqrt (msq1), 'msq1: ', msq1 print *, 'm2: ', sqrt (msq2), 'msq2: ', msq2 stop end if p = sqrt (lda) / (two * m) E1 = sqrt (msq1 + p**2) E2 = sqrt (msq2 + p**2) p1_out = shift_momentum (p1_rest, E1, p) p2_out = shift_momentum (p2_rest, E2, p) L = boost (p_origin, p_origin**1) p1_out = L * p1_out p2_out = L * p2_out if (present (jac) .and. present (msq_in)) then jac = jac * sqrt(lda) / msq rlda_soft = sqrt (lambda (msq_in, msq1, msq2)) !!! We have to undo the Jacobian which has already been !!! supplied by the Born phase space. jac = jac * msq_in / rlda_soft end if contains subroutine get_rest_frame (p1_in, p2_in, p1_out, p2_out) type(vector4_t), intent(in) :: p1_in, p2_in type(vector4_t), intent(out) :: p1_out, p2_out type(lorentz_transformation_t) :: L L = inverse (boost (p1_in + p2_in, (p1_in + p2_in)**1)) p1_out = L * p1_in; p2_out = L * p2_in end subroutine get_rest_frame function shift_momentum (p_in, E, p) result (p_out) type(vector4_t) :: p_out type(vector4_t), intent(in) :: p_in real(default), intent(in) :: E, p type(vector3_t) :: vec vec%p(1:3) = p_in%p(1:3) / space_part_norm (p_in) p_out = vector4_moving (E, p * vec) end function shift_momentum end subroutine evaluate_one_to_two_splitting @ %def generate_on_shell_decay @ \subsection{Boosts} We build Lorentz transformations from boosts and rotations. In both cases we can supply a three-vector which defines the axis and (hyperbolic) angle. For a boost, this is the vector $\vec\beta=\vec p/E$, such that a particle at rest with mass $m$ is boosted to a particle with three-vector $\vec p$. Here, we have \begin{equation} \beta = \tanh\chi = p/E, \qquad \gamma = \cosh\chi = E/m, \qquad \beta\gamma = \sinh\chi = p/m \end{equation} <>= public :: boost <>= interface boost module procedure boost_from_rest_frame module procedure boost_from_rest_frame_vector3 module procedure boost_generic module procedure boost_canonical end interface @ %def boost @ In the first form, the argument is some four-momentum, the space part of which determines a direction, and the associated mass (which is not checked against the four-momentum). The boost vector $\gamma\vec\beta$ is then given by $\vec p/m$. This boosts from the rest frame of a particle to the current frame. To be explicit, if $\vec p$ is the momentum of a particle and $m$ its mass, $L(\vec p/m)$ is the transformation that turns $(m;\vec 0)$ into $(E;\vec p)$. Conversely, the inverse transformation boosts a vector \emph{into} the rest frame of a particle, in particular $(E;\vec p)$ into $(m;\vec 0)$. <>= elemental module function boost_from_rest_frame (p, m) result (L) type(lorentz_transformation_t) :: L type(vector4_t), intent(in) :: p real(default), intent(in) :: m end function boost_from_rest_frame elemental module function boost_from_rest_frame_vector3 (p, m) result (L) type(lorentz_transformation_t) :: L type(vector3_t), intent(in) :: p real(default), intent(in) :: m end function boost_from_rest_frame_vector3 <>= elemental module function boost_from_rest_frame (p, m) result (L) type(lorentz_transformation_t) :: L type(vector4_t), intent(in) :: p real(default), intent(in) :: m L = boost_from_rest_frame_vector3 (space_part (p), m) end function boost_from_rest_frame elemental module function boost_from_rest_frame_vector3 (p, m) result (L) type(lorentz_transformation_t) :: L type(vector3_t), intent(in) :: p real(default), intent(in) :: m type(vector3_t) :: beta_gamma real(default) :: bg2, g, c integer :: i,j if (m > eps0) then beta_gamma = p / m bg2 = beta_gamma**2 else bg2 = 0 L = identity return end if if (bg2 > eps0) then g = sqrt(1 + bg2); c = (g-1)/bg2 else g = one + bg2 / two c = one / two end if L%L(0,0) = g L%L(0,1:) = beta_gamma%p L%L(1:,0) = L%L(0,1:) do i=1,3 do j=1,3 L%L(i,j) = delta_three(i,j) + c*beta_gamma%p(i)*beta_gamma%p(j) end do end do end function boost_from_rest_frame_vector3 @ %def boost_from_rest_frame @ A canonical boost is a boost along one of the coordinate axes, which we may supply as an integer argument. Here, $\gamma\beta$ is scalar. <>= elemental module function boost_canonical (beta_gamma, k) result (L) type(lorentz_transformation_t) :: L real(default), intent(in) :: beta_gamma integer, intent(in) :: k end function boost_canonical <>= elemental module function boost_canonical (beta_gamma, k) result (L) type(lorentz_transformation_t) :: L real(default), intent(in) :: beta_gamma integer, intent(in) :: k real(default) :: g g = sqrt(1 + beta_gamma**2) L = identity L%L(0,0) = g L%L(0,k) = beta_gamma L%L(k,0) = L%L(0,k) L%L(k,k) = L%L(0,0) end function boost_canonical @ %def boost_canonical @ Instead of a canonical axis, we can supply an arbitrary axis which need not be normalized. If it is zero, return the unit matrix. <>= elemental module function boost_generic (beta_gamma, axis) result (L) type(lorentz_transformation_t) :: L real(default), intent(in) :: beta_gamma type(vector3_t), intent(in) :: axis end function boost_generic <>= elemental module function boost_generic (beta_gamma, axis) result (L) type(lorentz_transformation_t) :: L real(default), intent(in) :: beta_gamma type(vector3_t), intent(in) :: axis if (any (abs (axis%p) > 0)) then L = boost_from_rest_frame_vector3 (beta_gamma * axis, axis**1) else L = identity end if end function boost_generic @ %def boost_generic @ \subsection{Rotations} For a rotation, the vector defines the rotation axis, and its length the rotation angle. All of these rotations rotate counterclockwise in a right-handed coordinate system. <>= public :: rotation <>= interface rotation module procedure rotation_generic module procedure rotation_canonical module procedure rotation_generic_cs module procedure rotation_canonical_cs end interface @ %def rotation @ If $\cos\phi$ and $\sin\phi$ is already known, we do not have to calculate them. Of course, the user has to ensure that $\cos^2\phi+\sin^2\phi=1$, and that the given axis [[n]] is normalized to one. In the second form, the length of [[axis]] is the rotation angle. <>= elemental module function rotation_generic_cs (cp, sp, axis) result (R) type(lorentz_transformation_t) :: R real(default), intent(in) :: cp, sp type(vector3_t), intent(in) :: axis end function rotation_generic_cs elemental module function rotation_generic (axis) result (R) type(lorentz_transformation_t) :: R type(vector3_t), intent(in) :: axis end function rotation_generic elemental module function rotation_canonical_cs (cp, sp, k) result (R) type(lorentz_transformation_t) :: R real(default), intent(in) :: cp, sp integer, intent(in) :: k end function rotation_canonical_cs elemental module function rotation_canonical (phi, k) result (R) type(lorentz_transformation_t) :: R real(default), intent(in) :: phi integer, intent(in) :: k end function rotation_canonical <>= elemental module function rotation_generic_cs (cp, sp, axis) result (R) type(lorentz_transformation_t) :: R real(default), intent(in) :: cp, sp type(vector3_t), intent(in) :: axis integer :: i,j R = identity do i=1,3 do j=1,3 R%L(i,j) = cp*delta_three(i,j) + (1-cp)*axis%p(i)*axis%p(j) & & - sp*dot_product(epsilon_three(i,j,:), axis%p) end do end do end function rotation_generic_cs elemental module function rotation_generic (axis) result (R) type(lorentz_transformation_t) :: R type(vector3_t), intent(in) :: axis real(default) :: phi if (any (abs(axis%p) > 0)) then phi = abs(axis**1) R = rotation_generic_cs (cos(phi), sin(phi), axis/phi) else R = identity end if end function rotation_generic @ %def rotation_generic_cs rotation_generic @ Alternatively, give just the angle and label the coordinate axis by an integer. <>= elemental module function rotation_canonical_cs (cp, sp, k) result (R) type(lorentz_transformation_t) :: R real(default), intent(in) :: cp, sp integer, intent(in) :: k integer :: i,j R = identity do i=1,3 do j=1,3 R%L(i,j) = -sp*epsilon_three(i,j,k) end do R%L(i,i) = cp end do R%L(k,k) = 1 end function rotation_canonical_cs elemental module function rotation_canonical (phi, k) result (R) type(lorentz_transformation_t) :: R real(default), intent(in) :: phi integer, intent(in) :: k R = rotation_canonical_cs(cos(phi), sin(phi), k) end function rotation_canonical @ %def rotation_canonical_cs rotation_canonical @ This is viewed as a method for the first argument (three-vector): Reconstruct the rotation that rotates it into the second three-vector. <>= public :: rotation_to_2nd <>= interface rotation_to_2nd module procedure rotation_to_2nd_generic module procedure rotation_to_2nd_canonical end interface <>= elemental module function rotation_to_2nd_generic (p, q) result (R) type(lorentz_transformation_t) :: R type(vector3_t), intent(in) :: p, q end function rotation_to_2nd_generic elemental module function rotation_to_2nd_canonical (k, p) result (R) type(lorentz_transformation_t) :: R integer, intent(in) :: k type(vector3_t), intent(in) :: p end function rotation_to_2nd_canonical <>= elemental module function rotation_to_2nd_generic (p, q) result (R) type(lorentz_transformation_t) :: R type(vector3_t), intent(in) :: p, q type(vector3_t) :: a, b, ab real(default) :: ct, st if (any (abs (p%p) > 0) .and. any (abs (q%p) > 0)) then a = direction (p) b = direction (q) ab = cross_product(a,b) ct = a * b; st = ab**1 if (abs(st) > eps0) then R = rotation_generic_cs (ct, st, ab / st) else if (ct < 0) then R = space_reflection else R = identity end if else R = identity end if end function rotation_to_2nd_generic @ %def rotation_to_2nd_generic @ The same for a canonical axis: The function returns the transformation that rotates the $k$-axis into the direction of $p$. <>= elemental module function rotation_to_2nd_canonical (k, p) result (R) type(lorentz_transformation_t) :: R integer, intent(in) :: k type(vector3_t), intent(in) :: p type(vector3_t) :: b, ab real(default) :: ct, st integer :: i, j if (any (abs (p%p) > 0)) then b = direction (p) ab%p = 0 do i = 1, 3 do j = 1, 3 ab%p(j) = ab%p(j) + b%p(i) * epsilon_three(i,j,k) end do end do ct = b%p(k); st = ab**1 if (abs(st) > eps0) then R = rotation_generic_cs (ct, st, ab / st) else if (ct < 0) then R = space_reflection else R = identity end if else R = identity end if end function rotation_to_2nd_canonical @ %def rotation_to_2nd_canonical @ \subsection{Composite Lorentz transformations} This function returns the transformation that, given a pair of vectors $p_{1,2}$, (a) boosts from the rest frame of the c.m. system (with invariant mass $m$) into the lab frame where $p_i$ are defined, and (b) turns the given axis (or the canonical vectors $\pm e_k$) in the rest frame into the directions of $p_{1,2}$ in the lab frame. Note that the energy components are not used; for a consistent result one should have $(p_1+p_2)^2 = m^2$. <>= public :: transformation <>= interface transformation module procedure transformation_rec_generic module procedure transformation_rec_canonical end interface @ %def transformation <>= elemental module function transformation_rec_generic (axis, p1, p2, m) result (L) type(vector3_t), intent(in) :: axis type(vector4_t), intent(in) :: p1, p2 real(default), intent(in) :: m type(lorentz_transformation_t) :: L end function transformation_rec_generic elemental module function transformation_rec_canonical (k, p1, p2, m) result (L) integer, intent(in) :: k type(vector4_t), intent(in) :: p1, p2 real(default), intent(in) :: m type(lorentz_transformation_t) :: L end function transformation_rec_canonical <>= elemental module function transformation_rec_generic (axis, p1, p2, m) result (L) type(vector3_t), intent(in) :: axis type(vector4_t), intent(in) :: p1, p2 real(default), intent(in) :: m type(lorentz_transformation_t) :: L L = boost (p1 + p2, m) L = L * rotation_to_2nd (axis, space_part (inverse (L) * p1)) end function transformation_rec_generic elemental module function transformation_rec_canonical (k, p1, p2, m) result (L) integer, intent(in) :: k type(vector4_t), intent(in) :: p1, p2 real(default), intent(in) :: m type(lorentz_transformation_t) :: L L = boost (p1 + p2, m) L = L * rotation_to_2nd (k, space_part (inverse (L) * p1)) end function transformation_rec_canonical @ %def transformation_rec_generic transformation_rec_canonical @ \subsection{Applying Lorentz transformations} Multiplying vectors and Lorentz transformations is straightforward. <>= interface operator(*) module procedure prod_LT_vector4 module procedure prod_LT_LT module procedure prod_vector4_LT end interface <>= elemental module function prod_LT_vector4 (L, p) result (np) type(vector4_t) :: np type(lorentz_transformation_t), intent(in) :: L type(vector4_t), intent(in) :: p end function prod_LT_vector4 elemental module function prod_LT_LT (L1, L2) result (NL) type(lorentz_transformation_t) :: NL type(lorentz_transformation_t), intent(in) :: L1,L2 end function prod_LT_LT elemental module function prod_vector4_LT (p, L) result (np) type(vector4_t) :: np type(vector4_t), intent(in) :: p type(lorentz_transformation_t), intent(in) :: L end function prod_vector4_LT <>= elemental module function prod_LT_vector4 (L, p) result (np) type(vector4_t) :: np type(lorentz_transformation_t), intent(in) :: L type(vector4_t), intent(in) :: p np%p = matmul (L%L, p%p) end function prod_LT_vector4 elemental module function prod_LT_LT (L1, L2) result (NL) type(lorentz_transformation_t) :: NL type(lorentz_transformation_t), intent(in) :: L1,L2 NL%L = matmul (L1%L, L2%L) end function prod_LT_LT elemental module function prod_vector4_LT (p, L) result (np) type(vector4_t) :: np type(vector4_t), intent(in) :: p type(lorentz_transformation_t), intent(in) :: L np%p = matmul (p%p, L%L) end function prod_vector4_LT @ %def * @ \subsection{Special Lorentz transformations} These routines have their application in the generation and extraction of angles in the phase-space sampling routine. Since this part of the program is time-critical, we calculate the composition of transformations directly instead of multiplying rotations and boosts. This Lorentz transformation is the composition of a rotation by $\phi$ around the $3$ axis, a rotation by $\theta$ around the $2$ axis, and a boost along the $3$ axis: \begin{equation} L = B_3(\beta\gamma)\,R_2(\theta)\,R_3(\phi) \end{equation} Instead of the angles we provide sine and cosine. <>= public :: LT_compose_r3_r2_b3 <>= elemental module function LT_compose_r3_r2_b3 & (cp, sp, ct, st, beta_gamma) result (L) type(lorentz_transformation_t) :: L real(default), intent(in) :: cp, sp, ct, st, beta_gamma end function LT_compose_r3_r2_b3 <>= elemental module function LT_compose_r3_r2_b3 & (cp, sp, ct, st, beta_gamma) result (L) type(lorentz_transformation_t) :: L real(default), intent(in) :: cp, sp, ct, st, beta_gamma real(default) :: gamma if (abs(beta_gamma) < eps0) then L%L(0,0) = 1 L%L(1:,0) = 0 L%L(0,1:) = 0 L%L(1,1:) = [ ct*cp, -ct*sp, st ] L%L(2,1:) = [ sp, cp, zero ] L%L(3,1:) = [ -st*cp, st*sp, ct ] else gamma = sqrt(1 + beta_gamma**2) L%L(0,0) = gamma L%L(1,0) = 0 L%L(2,0) = 0 L%L(3,0) = beta_gamma L%L(0,1:) = beta_gamma * [ -st*cp, st*sp, ct ] L%L(1,1:) = [ ct*cp, -ct*sp, st ] L%L(2,1:) = [ sp, cp, zero ] L%L(3,1:) = gamma * [ -st*cp, st*sp, ct ] end if end function LT_compose_r3_r2_b3 @ %def LT_compose_r3_r2_b3 @ Different ordering: \begin{equation} L = B_3(\beta\gamma)\,R_3(\phi)\,R_2(\theta) \end{equation} <>= public :: LT_compose_r2_r3_b3 <>= elemental module function LT_compose_r2_r3_b3 & (ct, st, cp, sp, beta_gamma) result (L) type(lorentz_transformation_t) :: L real(default), intent(in) :: ct, st, cp, sp, beta_gamma end function LT_compose_r2_r3_b3 <>= elemental module function LT_compose_r2_r3_b3 & (ct, st, cp, sp, beta_gamma) result (L) type(lorentz_transformation_t) :: L real(default), intent(in) :: ct, st, cp, sp, beta_gamma real(default) :: gamma if (abs(beta_gamma) < eps0) then L%L(0,0) = 1 L%L(1:,0) = 0 L%L(0,1:) = 0 L%L(1,1:) = [ ct*cp, -sp, st*cp ] L%L(2,1:) = [ ct*sp, cp, st*sp ] L%L(3,1:) = [ -st , zero, ct ] else gamma = sqrt(1 + beta_gamma**2) L%L(0,0) = gamma L%L(1,0) = 0 L%L(2,0) = 0 L%L(3,0) = beta_gamma L%L(0,1:) = beta_gamma * [ -st , zero, ct ] L%L(1,1:) = [ ct*cp, -sp, st*cp ] L%L(2,1:) = [ ct*sp, cp, st*sp ] L%L(3,1:) = gamma * [ -st , zero, ct ] end if end function LT_compose_r2_r3_b3 @ %def LT_compose_r2_r3_b3 @ This function returns the previous Lorentz transformation applied to an arbitrary four-momentum and extracts the space part of the result: \begin{equation} \vec n = [B_3(\beta\gamma)\,R_2(\theta)\,R_3(\phi)\,p]_{\rm space\ part} \end{equation} The second variant applies if there is no rotation <>= public :: axis_from_p_r3_r2_b3, axis_from_p_b3 <>= elemental module function axis_from_p_r3_r2_b3 & (p, cp, sp, ct, st, beta_gamma) result (n) type(vector3_t) :: n type(vector4_t), intent(in) :: p real(default), intent(in) :: cp, sp, ct, st, beta_gamma end function axis_from_p_r3_r2_b3 elemental module function axis_from_p_b3 (p, beta_gamma) result (n) type(vector3_t) :: n type(vector4_t), intent(in) :: p real(default), intent(in) :: beta_gamma end function axis_from_p_b3 <>= elemental module function axis_from_p_r3_r2_b3 & (p, cp, sp, ct, st, beta_gamma) result (n) type(vector3_t) :: n type(vector4_t), intent(in) :: p real(default), intent(in) :: cp, sp, ct, st, beta_gamma real(default) :: gamma, px, py px = cp * p%p(1) - sp * p%p(2) py = sp * p%p(1) + cp * p%p(2) n%p(1) = ct * px + st * p%p(3) n%p(2) = py n%p(3) = -st * px + ct * p%p(3) if (abs(beta_gamma) > eps0) then gamma = sqrt(1 + beta_gamma**2) n%p(3) = n%p(3) * gamma + p%p(0) * beta_gamma end if end function axis_from_p_r3_r2_b3 elemental module function axis_from_p_b3 (p, beta_gamma) result (n) type(vector3_t) :: n type(vector4_t), intent(in) :: p real(default), intent(in) :: beta_gamma real(default) :: gamma n%p = p%p(1:3) if (abs(beta_gamma) > eps0) then gamma = sqrt(1 + beta_gamma**2) n%p(3) = n%p(3) * gamma + p%p(0) * beta_gamma end if end function axis_from_p_b3 @ %def axis_from_p_r3_r2_b3 axis_from_p_b3 @ \subsection{Special functions} The K\"all\'en function, mostly used for the phase space. This is equivalent to $\lambda(x,y,z)=x^2+y^2+z^2-2xy-2xz-2yz$. <>= public :: lambda <>= elemental module function lambda (m1sq, m2sq, m3sq) real(default) :: lambda real(default), intent(in) :: m1sq, m2sq, m3sq end function lambda <>= elemental module function lambda (m1sq, m2sq, m3sq) real(default) :: lambda real(default), intent(in) :: m1sq, m2sq, m3sq lambda = (m1sq - m2sq - m3sq)**2 - 4*m2sq*m3sq end function lambda @ %def lambda @ Return a pair of head-to-head colliding momenta, given the collider energy, particle masses, and optionally the momentum of the c.m. system. <>= public :: colliding_momenta <>= module function colliding_momenta (sqrts, m, p_cm) result (p) type(vector4_t), dimension(2) :: p real(default), intent(in) :: sqrts real(default), dimension(2), intent(in), optional :: m real(default), intent(in), optional :: p_cm end function colliding_momenta <>= module function colliding_momenta (sqrts, m, p_cm) result (p) type(vector4_t), dimension(2) :: p real(default), intent(in) :: sqrts real(default), dimension(2), intent(in), optional :: m real(default), intent(in), optional :: p_cm real(default), dimension(2) :: dmsq real(default) :: ch, sh real(default), dimension(2) :: E0, p0 integer, dimension(2), parameter :: sgn = [1, -1] if (abs(sqrts) < eps0) then call msg_fatal (" Colliding beams: sqrts is zero (please set sqrts)") p = vector4_null; return else if (sqrts <= 0) then call msg_fatal (" Colliding beams: sqrts is negative") p = vector4_null; return end if if (present (m)) then dmsq = sgn * (m(1)**2-m(2)**2) E0 = (sqrts + dmsq/sqrts) / 2 if (any (E0 < m)) then call msg_fatal & (" Colliding beams: beam energy is less than particle mass") p = vector4_null; return end if p0 = sgn * sqrt (E0**2 - m**2) else E0 = sqrts / 2 p0 = sgn * E0 end if if (present (p_cm)) then sh = p_cm / sqrts ch = sqrt (1 + sh**2) p = vector4_moving (E0 * ch + p0 * sh, E0 * sh + p0 * ch, 3) else p = vector4_moving (E0, p0, 3) end if end function colliding_momenta @ %def colliding_momenta @ This subroutine is for the purpose of numerical checks and comparisons. The idea is to set a number to zero if it is numerically equivalent with zero. The equivalence is established by comparing with a [[tolerance]] argument. We implement this for vectors and transformations. <>= public :: pacify <>= interface pacify module procedure pacify_vector3 module procedure pacify_vector4 module procedure pacify_LT end interface pacify <>= elemental module subroutine pacify_vector3 (p, tolerance) type(vector3_t), intent(inout) :: p real(default), intent(in) :: tolerance end subroutine pacify_vector3 elemental module subroutine pacify_vector4 (p, tolerance) type(vector4_t), intent(inout) :: p real(default), intent(in) :: tolerance end subroutine pacify_vector4 elemental module subroutine pacify_LT (LT, tolerance) type(lorentz_transformation_t), intent(inout) :: LT real(default), intent(in) :: tolerance end subroutine pacify_LT <>= elemental module subroutine pacify_vector3 (p, tolerance) type(vector3_t), intent(inout) :: p real(default), intent(in) :: tolerance where (abs (p%p) < tolerance) p%p = zero end subroutine pacify_vector3 elemental module subroutine pacify_vector4 (p, tolerance) type(vector4_t), intent(inout) :: p real(default), intent(in) :: tolerance where (abs (p%p) < tolerance) p%p = zero end subroutine pacify_vector4 elemental module subroutine pacify_LT (LT, tolerance) type(lorentz_transformation_t), intent(inout) :: LT real(default), intent(in) :: tolerance where (abs (LT%L) < tolerance) LT%L = zero end subroutine pacify_LT @ %def pacify @ <>= public :: vector_set_reshuffle <>= module subroutine vector_set_reshuffle (p1, list, p2) type(vector4_t), intent(in), dimension(:), allocatable :: p1 integer, intent(in), dimension(:), allocatable :: list type(vector4_t), intent(out), dimension(:), allocatable :: p2 end subroutine vector_set_reshuffle <>= module subroutine vector_set_reshuffle (p1, list, p2) type(vector4_t), intent(in), dimension(:), allocatable :: p1 integer, intent(in), dimension(:), allocatable :: list type(vector4_t), intent(out), dimension(:), allocatable :: p2 integer :: n, n_p n_p = size (p1) if (size (list) /= n_p) return allocate (p2 (n_p)) do n = 1, n_p p2(n) = p1(list(n)) end do end subroutine vector_set_reshuffle @ %def vector_set_reshuffle @ <>= public :: vector_set_is_cms <>= module function vector_set_is_cms (p, n_in) result (is_cms) logical :: is_cms type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: n_in end function vector_set_is_cms <>= module function vector_set_is_cms (p, n_in) result (is_cms) logical :: is_cms type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: n_in integer :: i type(vector4_t) :: p_sum p_sum%p = 0._default do i = 1, n_in p_sum = p_sum + p(i) end do is_cms = all (abs (p_sum%p(1:3)) < tiny_07) end function vector_set_is_cms @ %def vector_set_is_cms @ <>= public :: vector_set_is_lab <>= module function vector_set_is_lab (p, n_in) result (is_lab) logical :: is_lab type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: n_in end function vector_set_is_lab <>= module function vector_set_is_lab (p, n_in) result (is_lab) logical :: is_lab type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: n_in is_lab = .not. vector_set_is_cms (p, n_in) end function vector_set_is_lab @ %def vector_set_is_lab @ <>= public :: vector4_write_set <>= module subroutine vector4_write_set (p, unit, show_mass, testflag, & check_conservation, ultra, n_in) type(vector4_t), intent(in), dimension(:) :: p integer, intent(in), optional :: unit logical, intent(in), optional :: show_mass logical, intent(in), optional :: testflag, ultra logical, intent(in), optional :: check_conservation integer, intent(in), optional :: n_in end subroutine vector4_write_set <>= module subroutine vector4_write_set (p, unit, show_mass, testflag, & check_conservation, ultra, n_in) type(vector4_t), intent(in), dimension(:) :: p integer, intent(in), optional :: unit logical, intent(in), optional :: show_mass logical, intent(in), optional :: testflag, ultra logical, intent(in), optional :: check_conservation integer, intent(in), optional :: n_in logical :: extreme integer :: i, j real(default), dimension(0:3) :: p_tot character(len=7) :: fmt integer :: u logical :: yorn, is_test integer :: n extreme = .false.; if (present (ultra)) extreme = ultra is_test = .false.; if (present (testflag)) is_test = testflag u = given_output_unit (unit); if (u < 0) return n = 2; if (present (n_in)) n = n_in p_tot = 0 yorn = .false.; if (present (check_conservation)) yorn = check_conservation do i = 1, size (p) if (yorn .and. i > n) then forall (j=0:3) p_tot(j) = p_tot(j) - p(i)%p(j) else forall (j=0:3) p_tot(j) = p_tot(j) + p(i)%p(j) end if call vector4_write (p(i), u, show_mass=show_mass, & testflag=testflag, ultra=ultra) end do if (extreme) then call pac_fmt (fmt, FMT_19, FMT_11, testflag) else call pac_fmt (fmt, FMT_19, FMT_15, testflag) end if if (is_test) call pacify (p_tot, 1.E-9_default) if (.not. is_test) then write (u, "(A5)") 'Total: ' write (u, "(1x,A,1x," // fmt // ")") "E = ", p_tot(0) write (u, "(1x,A,3(1x," // fmt // "))") "P = ", p_tot(1:) end if end subroutine vector4_write_set @ %def vector4_write_set @ <>= public :: vector4_check_momentum_conservation <>= module subroutine vector4_check_momentum_conservation (p, n_in, unit, & abs_smallness, rel_smallness, verbose) type(vector4_t), dimension(:), intent(in) :: p integer, intent(in) :: n_in integer, intent(in), optional :: unit real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: verbose end subroutine vector4_check_momentum_conservation <>= module subroutine vector4_check_momentum_conservation (p, n_in, unit, & abs_smallness, rel_smallness, verbose) type(vector4_t), dimension(:), intent(in) :: p integer, intent(in) :: n_in integer, intent(in), optional :: unit real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: verbose integer :: u, i type(vector4_t) :: psum_in, psum_out logical, dimension(0:3) :: p_diff logical :: verb u = given_output_unit (unit); if (u < 0) return verb = .false.; if (present (verbose)) verb = verbose psum_in = vector4_null do i = 1, n_in psum_in = psum_in + p(i) end do psum_out = vector4_null do i = n_in + 1, size (p) psum_out = psum_out + p(i) end do p_diff = vanishes (psum_in%p - psum_out%p, & abs_smallness = abs_smallness, rel_smallness = rel_smallness) if (.not. all (p_diff)) then call msg_warning ("Momentum conservation: FAIL", unit = u) if (verb) then write (u, "(A)") "Incoming:" call vector4_write (psum_in, u) write (u, "(A)") "Outgoing:" call vector4_write (psum_out, u) end if else if (verb) then write (u, "(A)") "Momentum conservation: CHECK" end if end if end subroutine vector4_check_momentum_conservation @ %def vector4_check_momentum_conservation @ This computes the quantities \begin{align*} \langle ij \rangle &= \sqrt{|S_{ij}|} e^{i\phi_{ij}}, [ij] &= \sqrt{|S_{ij}|} e^{\i\tilde{\phi}_{ij}}, \end{align*} with $S_{ij} = \left(p_i + p_j\right)^2$. The phase space factor $\phi_{ij}$ is determined by \begin{align*} \cos\phi_{ij} &= \frac{p_i^1p_j^+ - p_j^1p_i^+}{\sqrt{p_i^+p_j^+S_{ij}}}, \sin\phi_{ij} &= \frac{p_i^2p_j^+ - p_j^2p_i^+}{\sqrt{p_i^+p_j^+S_{ij}}}. \end{align*} After $\langle ij \rangle$ has been computed according to these formulae, $[ij]$ can be obtained by using the relation $S_{ij} = \langle ij \rangle [ji]$ and taking into account that $[ij] = -[ji]$. Thus, a minus-sign has to be applied. <>= public :: spinor_product <>= module subroutine spinor_product (p1, p2, prod1, prod2) type(vector4_t), intent(in) :: p1, p2 complex(default), intent(out) :: prod1, prod2 end subroutine spinor_product <>= module subroutine spinor_product (p1, p2, prod1, prod2) type(vector4_t), intent(in) :: p1, p2 complex(default), intent(out) :: prod1, prod2 real(default) :: sij complex(default) :: phase real(default) :: pp_1, pp_2 pp_1 = p1%p(0) + p1%p(3) pp_2 = p2%p(0) + p2%p(3) sij = (p1+p2)**2 phase = cmplx ((p1%p(1)*pp_2 - p2%p(1)*pp_1)/sqrt (sij*pp_1*pp_2), & (p1%p(2)*pp_2 - p2%p(2)*pp_1)/sqrt (sij*pp_1*pp_2), & default) !!! prod1 = sqrt (sij) * phase !!! [ij] if (abs(prod1) > 0) then prod2 = - sij / prod1 else prod2 = 0 end if end subroutine spinor_product @ %def spinor_product %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Collections of Lorentz Vectors} The [[phs_point]] type is a container for an array of Lorentz vectors. This allows us to transfer Lorentz-vector arrays more freely, and to collect vector arrays of non-uniform size. <<[[phs_points.f90]]>>= <> module phs_points <> use lorentz, only: vector4_t use lorentz, only: lorentz_transformation_t use lorentz, only: sum <> <> <> <> interface <> end interface end module phs_points @ %def phs_points @ <<[[phs_points_sub.f90]]>>= <> submodule (phs_points) phs_points_s use lorentz, only: vector4_null use lorentz, only: vector4_write_set use lorentz, only: operator(==) use lorentz, only: operator(*) use lorentz, only: operator(**) implicit none contains <> end submodule phs_points_s @ %def phs_points_s @ \subsection{PHS point definition} This is a trivial container for an array of momenta. The main application is to store a non-uniform array of phase-space points. <>= public :: phs_point_t <>= type :: phs_point_t private type(vector4_t), dimension(:), allocatable :: p contains <> end type phs_point_t @ %def phs_point_t @ \subsection{PHS point: basic tools} Output. This is instrumented with options, which have to be provided by the caller. <>= procedure :: write => phs_point_write <>= module subroutine phs_point_write (phs_point, unit, show_mass, testflag, & check_conservation, ultra, n_in) class(phs_point_t), intent(in) :: phs_point integer, intent(in), optional :: unit logical, intent(in), optional :: show_mass logical, intent(in), optional :: testflag, ultra logical, intent(in), optional :: check_conservation integer, intent(in), optional :: n_in end subroutine phs_point_write <>= module subroutine phs_point_write (phs_point, unit, show_mass, testflag, & check_conservation, ultra, n_in) class(phs_point_t), intent(in) :: phs_point integer, intent(in), optional :: unit logical, intent(in), optional :: show_mass logical, intent(in), optional :: testflag, ultra logical, intent(in), optional :: check_conservation integer, intent(in), optional :: n_in if (allocated (phs_point%p)) then call vector4_write_set (phs_point%p, & unit = unit, & show_mass = show_mass, & testflag = testflag, & check_conservation = check_conservation, & ultra = ultra, & n_in = n_in) end if end subroutine phs_point_write @ %def phs_point_write @ Non-intrinsic assignment <>= public :: assignment(=) <>= interface assignment(=) module procedure phs_point_from_n module procedure phs_point_from_vector4 module procedure vector4_from_phs_point end interface @ Initialize with zero momenta but fixed size <>= pure module subroutine phs_point_from_n (phs_point, n_particles) type(phs_point_t), intent(out) :: phs_point integer, intent(in) :: n_particles end subroutine phs_point_from_n <>= pure module subroutine phs_point_from_n (phs_point, n_particles) type(phs_point_t), intent(out) :: phs_point integer, intent(in) :: n_particles allocate (phs_point%p (n_particles), source = vector4_null) end subroutine phs_point_from_n @ %def phs_point_init_from_n @ Transform from/to plain vector array <>= pure module subroutine phs_point_from_vector4 (phs_point, p) type(phs_point_t), intent(out) :: phs_point type(vector4_t), dimension(:), intent(in) :: p end subroutine phs_point_from_vector4 pure module subroutine vector4_from_phs_point (p, phs_point) class(phs_point_t), intent(in) :: phs_point type(vector4_t), dimension(:), allocatable, intent(out) :: p end subroutine vector4_from_phs_point <>= pure module subroutine phs_point_from_vector4 (phs_point, p) type(phs_point_t), intent(out) :: phs_point type(vector4_t), dimension(:), intent(in) :: p phs_point%p = p end subroutine phs_point_from_vector4 pure module subroutine vector4_from_phs_point (p, phs_point) class(phs_point_t), intent(in) :: phs_point type(vector4_t), dimension(:), allocatable, intent(out) :: p if (allocated (phs_point%p)) p = phs_point%p end subroutine vector4_from_phs_point @ %def phs_point_from_vector4 @ %def vector4_from_phs_point @ Query the size of the momentum array (assuming it is allocated). <>= public :: size <>= interface size module procedure phs_point_size end interface size <>= pure module function phs_point_size (phs_point) result (s) class(phs_point_t), intent(in) :: phs_point integer :: s end function phs_point_size <>= pure module function phs_point_size (phs_point) result (s) class(phs_point_t), intent(in) :: phs_point integer :: s if (allocated (phs_point%p)) then s = size (phs_point%p) else s = 0 end if end function phs_point_size @ %def phs_point_size @ Equality, implemented only for valid points. <>= public :: operator(==) <>= interface operator(==) module procedure phs_point_eq end interface operator(==) <>= elemental module function phs_point_eq & (phs_point_1, phs_point_2) result (flag) class(phs_point_t), intent(in) :: phs_point_1, phs_point_2 logical :: flag end function phs_point_eq <>= elemental module function phs_point_eq & (phs_point_1, phs_point_2) result (flag) class(phs_point_t), intent(in) :: phs_point_1, phs_point_2 logical :: flag if (allocated (phs_point_1%p) .and. (allocated (phs_point_2%p))) then flag = all (phs_point_1%p == phs_point_2%p) else flag = .false. end if end function phs_point_eq @ %def phs_point_eq @ Extract all momenta, as a method <>= procedure :: get => phs_point_get <>= pure module function phs_point_get (phs_point) result (p) class(phs_point_t), intent(in) :: phs_point type(vector4_t), dimension(:), allocatable :: p end function phs_point_get <>= pure module function phs_point_get (phs_point) result (p) class(phs_point_t), intent(in) :: phs_point type(vector4_t), dimension(:), allocatable :: p if (allocated (phs_point%p)) then p = phs_point%p else allocate (p (0)) end if end function phs_point_get @ %def phs_point_select @ Extract a subset of all momenta. <>= procedure :: select => phs_point_select <>= elemental module function phs_point_select (phs_point, i) result (p) class(phs_point_t), intent(in) :: phs_point integer, intent(in) :: i type(vector4_t) :: p end function phs_point_select <>= elemental module function phs_point_select (phs_point, i) result (p) class(phs_point_t), intent(in) :: phs_point integer, intent(in) :: i type(vector4_t) :: p if (allocated (phs_point%p)) then p = phs_point%p(i) else p = vector4_null end if end function phs_point_select @ %def phs_point_select @ Return the invariant mass squared for a subset of momenta <>= procedure :: get_msq => phs_point_get_msq <>= pure module function phs_point_get_msq (phs_point, iarray) result (msq) class(phs_point_t), intent(in) :: phs_point integer, dimension(:), intent(in) :: iarray real(default) :: msq end function phs_point_get_msq <>= pure module function phs_point_get_msq (phs_point, iarray) result (msq) class(phs_point_t), intent(in) :: phs_point integer, dimension(:), intent(in) :: iarray real(default) :: msq if (allocated (phs_point%p)) then msq = (sum (phs_point%p(iarray)))**2 else msq = 0 end if end function phs_point_get_msq @ %def phs_point_get_msq @ \subsection{Lorentz algebra pieces} Lorentz transformation. <>= public :: operator(*) <>= interface operator(*) module procedure prod_LT_phs_point end interface operator(*) <>= elemental module function prod_LT_phs_point (L, phs_point) result (phs_point_LT) type(lorentz_transformation_t), intent(in) :: L type(phs_point_t), intent(in) :: phs_point type(phs_point_t) :: phs_point_LT end function prod_LT_phs_point <>= elemental module function prod_LT_phs_point (L, phs_point) result (phs_point_LT) type(lorentz_transformation_t), intent(in) :: L type(phs_point_t), intent(in) :: phs_point type(phs_point_t) :: phs_point_LT if (allocated (phs_point%p)) phs_point_LT%p = L * phs_point%p end function prod_LT_phs_point @ %def prod_LT_phs_point @ Compute momentum sum, analogous to the standard [[sum]] function (mask), and additionally using an index array. <>= public :: sum <>= interface sum module procedure phs_point_sum module procedure phs_point_sum_iarray end interface sum <>= pure module function phs_point_sum (phs_point, mask) result (p) class(phs_point_t), intent(in) :: phs_point logical, dimension(:), intent(in), optional :: mask type(vector4_t) :: p end function phs_point_sum pure module function phs_point_sum_iarray (phs_point, iarray) result (p) class(phs_point_t), intent(in) :: phs_point integer, dimension(:), intent(in) :: iarray type(vector4_t) :: p end function phs_point_sum_iarray <>= pure module function phs_point_sum (phs_point, mask) result (p) class(phs_point_t), intent(in) :: phs_point logical, dimension(:), intent(in), optional :: mask type(vector4_t) :: p if (allocated (phs_point%p)) then p = sum (phs_point%p, mask) else p = vector4_null end if end function phs_point_sum pure module function phs_point_sum_iarray (phs_point, iarray) result (p) class(phs_point_t), intent(in) :: phs_point integer, dimension(:), intent(in) :: iarray type(vector4_t) :: p logical, dimension(:), allocatable :: mask integer :: i allocate (mask (size (phs_point)), source = .false.) mask(iarray) = .true. p = sum (phs_point, mask) end function phs_point_sum_iarray @ %def phs_point_sum @ \subsection{Methods for specific applications} Convenience method: compute the pair of energy fractions w.r.t.\ the specified beam energy. We assume that the momenta represent a scattering process (two incoming particles) in the c.m.\ frame. <>= procedure :: get_x => phs_point_get_x <>= pure module function phs_point_get_x (phs_point, E_beam) result (x) class(phs_point_t), intent(in) :: phs_point real(default), dimension(2) :: x real(default), intent(in) :: E_beam end function phs_point_get_x <>= pure module function phs_point_get_x (phs_point, E_beam) result (x) class(phs_point_t), intent(in) :: phs_point real(default), dimension(2) :: x real(default), intent(in) :: E_beam x = phs_point%p(1:2)%p(0) / E_beam end function phs_point_get_x @ %def phs_point_get_x @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[phs_points_ut.f90]]>>= <> module phs_points_ut use unit_tests use phs_points_uti <> <> contains <> end module phs_points_ut @ %def phs_points_ut @ <<[[phs_points_uti.f90]]>>= <> module phs_points_uti <> use phs_points <> <> contains <> end module phs_points_uti @ %def phs_points_ut @ API: driver for the unit tests below. <>= public :: phs_points_test <>= subroutine phs_points_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine phs_points_test @ %def phs_points_test @ \subsubsection{Splitting functions} <>= call test (phs_points_1, "phs_points_1", & "Dummy test", & u, results) <>= public :: phs_points_1 <>= subroutine phs_points_1 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: phs_points_1" write (u, "(A)") "* Purpose: none yet" write (u, "(A)") write (u, "(A)") write (u, "(A)") "* Test output end: phs_points_1" end subroutine phs_points_1 @ %def phs_points_1 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Special Physics functions} Here, we declare functions that are specific for the Standard Model, including QCD: fixed and running $\alpha_s$, Catani-Seymour dipole terms, loop functions, etc. To make maximum use of this, all functions, if possible, are declared elemental (or pure, if this is not possible). <<[[sm_physics.f90]]>>= <> module sm_physics <> use constants use physics_defs use lorentz <> <> <> interface <> end interface end module sm_physics @ %def sm_physics @ <<[[sm_physics_sub.f90]]>>= <> submodule (sm_physics) sm_physics_s use io_units use numeric_utils use diagnostics use permutations, only: factorial implicit none contains <> end submodule sm_physics_s @ %def sm_physics_s @ \subsection{Constants for Quantum Field Theory calculations} For loop calculations in quantum field theories, one needs the numerical values of the Riemann zeta function: \begin{align*} \zeta(2) &=\; 1.64493406684822643647241516665\ldots \; \\ \zeta(3) &=\; 1.20205690315959428539973816151\ldots \; \\ \zeta(4) &=\; 1.08232323371113819151600369654\ldots \; \\ \zeta(5) &=\; 1.03692775514336992633136548646\ldots \; \end{align*} <>= public :: zeta2, zeta3, zeta4, zeta5 <>= real(default), parameter :: & zeta2 = 1.64493406684822643647241516665_default, & zeta3 = 1.20205690315959428539973816151_default, & zeta4 = 1.08232323371113819151600369654_default, & zeta5 = 1.03692775514336992633136548646_default @ %def zeta2 zeta3 zeta4 @ The Euler-Mascheroni constant is \begin{equation*} \gamma_E = \end{equation*} <>= public :: eulerc <>= real(default), parameter :: & eulerc =0.5772156649015328606065120900824024310422_default @ %def eulerc @ \subsection{Running $\alpha_s$} Then we define the coefficients of the beta function of QCD (as a reference cf. the Particle Data Group), where $n_f$ is the number of active flavors in two different schemes: \begin{align} \beta_0 &=\; 11 - \frac23 n_f \\ \beta_1 &=\; 51 - \frac{19}{3} n_f \\ \beta_2 &=\; 2857 - \frac{5033}{9} n_f + \frac{325}{27} n_f^2 \end{align} \begin{align} b_0 &=\; \frac{1}{12 \pi} \left( 11 C_A - 2 n_f \right) \\ b_1 &=\; \frac{1}{24 \pi^2} \left( 17 C_A^2 - 5 C_A n_f - 3 C_F n_f \right) \\ b_2 &=\; \frac{1}{(4\pi)^3} \biggl( \frac{2857}{54} C_A^3 - \frac{1415}{54} * C_A^2 n_f - \frac{205}{18} C_A C_F n_f + C_F^2 n_f + \frac{79}{54} C_A n_f**2 + \frac{11}{9} C_F n_f**2 \biggr) \end{align} The functions [[sumQ2q]] and [[sumQ4q]] provide the sum of the squared and quartic electric charges of a number [[nf]] of active quark flavors. <>= public :: beta0, beta1, beta2 public :: coeff_b0, coeff_b1, coeff_b2, coeffqed_b0, coeffqed_b1 <>= pure module function beta0 (nf) real(default), intent(in) :: nf real(default) :: beta0 end function beta0 pure module function beta1 (nf) real(default), intent(in) :: nf real(default) :: beta1 end function beta1 pure module function beta2 (nf) real(default), intent(in) :: nf real(default) :: beta2 end function beta2 pure module function coeff_b0 (nf) real(default), intent(in) :: nf real(default) :: coeff_b0 end function coeff_b0 pure module function coeff_b1 (nf) real(default), intent(in) :: nf real(default) :: coeff_b1 end function coeff_b1 pure module function coeff_b2 (nf) real(default), intent(in) :: nf real(default) :: coeff_b2 end function coeff_b2 pure module function coeffqed_b0 (nf, nlep) integer, intent(in) :: nf, nlep real(default) :: n_lep, coeffqed_b0 end function coeffqed_b0 pure module function coeffqed_b1 (nf, nlep) integer, intent(in) :: nf, nlep real(default) :: n_lep, coeffqed_b1 end function coeffqed_b1 <>= pure module function beta0 (nf) real(default), intent(in) :: nf real(default) :: beta0 beta0 = 11.0_default - two/three * nf end function beta0 pure module function beta1 (nf) real(default), intent(in) :: nf real(default) :: beta1 beta1 = 51.0_default - 19.0_default/three * nf end function beta1 pure module function beta2 (nf) real(default), intent(in) :: nf real(default) :: beta2 beta2 = 2857.0_default - 5033.0_default / 9.0_default * & nf + 325.0_default/27.0_default * nf**2 end function beta2 pure module function coeff_b0 (nf) real(default), intent(in) :: nf real(default) :: coeff_b0 coeff_b0 = (11.0_default * CA - two * nf) / (12.0_default * pi) end function coeff_b0 pure module function coeff_b1 (nf) real(default), intent(in) :: nf real(default) :: coeff_b1 coeff_b1 = (17.0_default * CA**2 - five * CA * nf - three * CF * nf) / & (24.0_default * pi**2) end function coeff_b1 pure module function coeff_b2 (nf) real(default), intent(in) :: nf real(default) :: coeff_b2 coeff_b2 = (2857.0_default/54.0_default * CA**3 - & 1415.0_default/54.0_default * & CA**2 * nf - 205.0_default/18.0_default * CA*CF*nf & + 79.0_default/54.0_default * CA*nf**2 + & 11.0_default/9.0_default * CF * nf**2) / (four*pi)**3 end function coeff_b2 pure module function coeffqed_b0 (nf, nlep) integer, intent(in) :: nf, nlep real(default) :: n_lep, coeffqed_b0 n_lep = real(nlep, kind=default) coeffqed_b0 = - (three * sumQ2q (nf) + n_lep) / (three*pi) end function coeffqed_b0 pure module function coeffqed_b1 (nf, nlep) integer, intent(in) :: nf, nlep real(default) :: n_lep, coeffqed_b1 n_lep = real(nlep, kind=default) coeffqed_b1 = - (three * sumQ4q (nf) + n_lep) / (four*pi**2) end function coeffqed_b1 pure function sumQ2q (nf) integer, intent(in) :: nf real(default) :: sumQ2q select case (nf) case (0) sumQ2q = zero case (1) sumQ2q = 1.0_default/9.0_default case (2) sumQ2q = 5.0_default/9.0_default case (3) sumQ2q = 2.0_default/3.0_default case (4) sumQ2q = 10.0_default/9.0_default case (5) sumQ2q = 11.0_default/9.0_default case (6:) sumQ2q = 5.0_default/3.0_default end select end function sumQ2q pure function sumQ4q (nf) integer, intent(in) :: nf real(default) :: sumQ4q select case (nf) case (0) sumQ4q = zero case (1) sumQ4q = 1.0_default/81.0_default case (2) sumQ4q = 17.0_default/81.0_default case (3) sumQ4q = 2.0_default/9.0_default case (4) sumQ4q = 34.0_default/81.0_default case (5) sumQ4q = 35.0_default/81.0_default case (6:) sumQ4q = 17.0_default/27.0_default end select end function sumQ4q @ %def beta0 beta1 beta2 @ %def coeff_b0 coeff_b1 coeff_b2 coeffqed_b0 coeffqed_b1 @ %def sumQ2q sumQ4q @ There should be two versions of running $\alpha_s$, one which takes the scale and $\Lambda_{\text{QCD}}$ as input, and one which takes the scale and e.g. $\alpha_s(m_Z)$ as input. Here, we take the one which takes the QCD scale and scale as inputs from the PDG book. <>= public :: running_as, running_as_lam, running_alpha, running_alpha_num <>= pure module function running_as (scale, al_mz, mz, order, nf) result (ascale) real(default), intent(in) :: scale real(default), intent(in), optional :: al_mz, nf, mz integer, intent(in), optional :: order real(default) :: ascale end function running_as pure module function running_as_lam (nf, scale, lambda, order) result (ascale) real(default), intent(in) :: nf, scale real(default), intent(in), optional :: lambda integer, intent(in), optional :: order real(default) :: ascale end function running_as_lam pure module function running_alpha & (scale, al_me, me, order, nf, nlep) result (ascale) real(default), intent(in) :: scale real(default), intent(in), optional :: al_me, me integer, intent(in), optional :: order, nf, nlep real(default) :: ascale end function running_alpha pure module function running_alpha_num & (scale, al_me, me, order, nf, nlep) result (ascale) real(default), intent(in) :: scale real(default), intent(in), optional :: al_me, me integer, intent(in), optional :: order, nf, nlep real(default) :: ascale end function running_alpha_num <>= pure module function running_as (scale, al_mz, mz, order, nf) result (ascale) real(default), intent(in) :: scale real(default), intent(in), optional :: al_mz, nf, mz integer, intent(in), optional :: order integer :: ord real(default) :: az, m_z, as_log, n_f, b0, b1, b2, ascale real(default) :: as0, as1 if (present (mz)) then m_z = mz else m_z = MZ_REF end if if (present (order)) then ord = order else ord = 0 end if if (present (al_mz)) then az = al_mz else az = ALPHA_QCD_MZ_REF end if if (present (nf)) then n_f = nf else n_f = 5 end if b0 = coeff_b0 (n_f) b1 = coeff_b1 (n_f) b2 = coeff_b2 (n_f) as_log = one + b0 * az * log(scale**2/m_z**2) as0 = az / as_log as1 = as0 - as0**2 * b1/b0 * log(as_log) select case (ord) case (0) ascale = as0 case (1) ascale = as1 case (2) ascale = as1 + as0**3 * (b1**2/b0**2 * ((log(as_log))**2 - & log(as_log) + as_log - one) - b2/b0 * (as_log - one)) case default ascale = as0 end select end function running_as pure module function running_as_lam (nf, scale, lambda, order) result (ascale) real(default), intent(in) :: nf, scale real(default), intent(in), optional :: lambda integer, intent(in), optional :: order real(default) :: lambda_qcd real(default) :: as0, as1, logmul, b0, b1, b2, ascale integer :: ord if (present (lambda)) then lambda_qcd = lambda else lambda_qcd = LAMBDA_QCD_REF end if if (present (order)) then ord = order else ord = 0 end if b0 = beta0(nf) logmul = log(scale**2/lambda_qcd**2) as0 = four*pi / b0 / logmul if (ord > 0) then b1 = beta1(nf) as1 = as0 * (one - two* b1 / b0**2 * log(logmul) / logmul) end if select case (ord) case (0) ascale = as0 case (1) ascale = as1 case (2) b2 = beta2(nf) ascale = as1 + as0 * four * b1**2/b0**4/logmul**2 * & ((log(logmul) - 0.5_default)**2 + & b2*b0/8.0_default/b1**2 - five/four) case default ascale = as0 end select end function running_as_lam pure module function running_alpha & (scale, al_me, me, order, nf, nlep) result (ascale) real(default), intent(in) :: scale real(default), intent(in), optional :: al_me, me integer, intent(in), optional :: order, nf, nlep integer :: ord, n_f, n_lep real(default) :: ae, m_e, a_log, b0, b1, ascale real(default) :: a0, a1 if (present (me)) then m_e = me else m_e = ME_REF end if if (present (order)) then ord = order else ord = 0 end if if (present (al_me)) then ae = al_me else ae = ALPHA_QED_ME_REF end if if (present (nf)) then n_f = nf else n_f = 5 end if if (present (nlep)) then n_lep = nlep else n_lep = 1 end if b0 = coeffqed_b0 (n_f, n_lep) b1 = coeffqed_b1 (n_f, n_lep) a_log = one + b0 * ae * log(scale**2/m_e**2) a0 = ae / a_log a1 = ae / (a_log + ae * b1/b0 * & log((a_log + ae * b1/b0)/(one + ae * b1/b0))) select case (ord) case (0) ascale = a0 case (1) ascale = a1 case default ascale = a0 end select end function running_alpha pure module function running_alpha_num & (scale, al_me, me, order, nf, nlep) result (ascale) real(default), intent(in) :: scale real(default), intent(in), optional :: al_me, me integer, intent(in), optional :: order, nf, nlep integer, parameter :: n_steps = 20 integer :: ord, n_f, n_lep, k1 real(default), parameter :: sxth = 1._default/6._default real(default) :: ae, ascale, m_e, log_q, dlr, & b0, b1, xk0, xk1, xk2, xk3 if (present (order)) then ord = order else ord = 0 end if if (present (al_me)) then ae = al_me else ae = ALPHA_QED_ME_REF end if if (present (me)) then m_e = me else m_e = ME_REF end if if (present (nf)) then n_f = nf else n_f = 5 end if if (present (nlep)) then n_lep = nlep else n_lep = 1 end if ascale = ae log_q = log (scale**2/m_e**2) dlr = log_q / n_steps b0 = coeffqed_b0 (n_f, n_lep) b1 = coeffqed_b1 (n_f, n_lep) ! ..Solution of the evolution equation depending on ORD ! (fourth-order Runge-Kutta beyond the leading order) select case (ord) case (0) ascale = ae / (one + b0 * ae * log_q) case (1:) do k1 = 1, n_steps xk0 = dlr * beta_qed (ascale) xk1 = dlr * beta_qed (ascale + 0.5 * xk0) xk2 = dlr * beta_qed (ascale + 0.5 * xk1) xk3 = dlr * beta_qed (ascale + xk2) ascale = ascale + sxth * (xk0 + 2._default * xk1 + & 2._default * xk2 + xk3) end do end select contains pure function beta_qed (alpha) real(default), intent(in) :: alpha real(default) :: beta_qed beta_qed = - alpha**2 * (b0 + alpha * b1) end function beta_qed end function running_alpha_num @ %def running_as @ %def running_as_lam @ %def running_alpha running_alpha_num @ \subsection{Catani-Seymour Parameters} These are fundamental constants of the Catani-Seymour dipole formalism. Since the corresponding parameters for the gluon case depend on the number of flavors which is treated as an argument, there we do have functions and not parameters. \begin{equation} \gamma_q = \gamma_{\bar q} = \frac{3}{2} C_F \qquad \gamma_g = \frac{11}{6} C_A - \frac{2}{3} T_R N_f \end{equation} \begin{equation} K_q = K_{\bar q} = \left( \frac{7}{2} - \frac{\pi^2}{6} \right) C_F \qquad K_g = \left( \frac{67}{18} - \frac{\pi^2}{6} \right) C_A - \frac{10}{9} T_R N_f \end{equation} <>= real(default), parameter, public :: gamma_q = three/two * CF, & k_q = (7.0_default/two - pi**2/6.0_default) * CF @ %def gamma_q @ <>= public :: gamma_g, k_g <>= elemental module function gamma_g (nf) result (gg) real(default), intent(in) :: nf real(default) :: gg end function gamma_g elemental module function k_g (nf) result (kg) real(default), intent(in) :: nf real(default) :: kg end function k_g <>= elemental module function gamma_g (nf) result (gg) real(default), intent(in) :: nf real(default) :: gg gg = 11.0_default/6.0_default * CA - two/three * TR * nf end function gamma_g elemental module function k_g (nf) result (kg) real(default), intent(in) :: nf real(default) :: kg kg = (67.0_default/18.0_default - pi**2/6.0_default) * CA - & 10.0_default/9.0_default * TR * nf end function k_g @ %def gamma_g @ %def k_g @ \subsection{Mathematical Functions} The dilogarithm. This simplified version is bound to double precision, and restricted to argument values less or equal to unity, so we do not need complex algebra. The wrapper converts it to default precision (which is, of course, a no-op if double=default). The routine calculates the dilogarithm through mapping on the area where there is a quickly convergent series (adapted from an F77 routine by Hans Kuijf, 1988): Map $x$ such that $x$ is not in the neighbourhood of $1$. Note that $|z|=-\ln(1-x)$ is always smaller than $1.10$, but $\frac{1.10^{19}}{19!}{\rm Bernoulli}_{19}=2.7\times 10^{-15}$. <>= public :: Li2 <>= elemental module function Li2 (x) real(default), intent(in) :: x real(default) :: Li2 end function Li2 <>= elemental module function Li2 (x) real(default), intent(in) :: x real(default) :: Li2 Li2 = real( Li2_double (real(x, kind=double)), kind=default) end function Li2 @ %def: Li2 @ <>= elemental function Li2_double (x) result (Li2) real(double), intent(in) :: x real(double) :: Li2 real(double), parameter :: pi2_6 = pi**2/6 if (abs(1-x) < tiny_07) then Li2 = pi2_6 else if (abs(1-x) < 0.5_double) then Li2 = pi2_6 - log(1-x) * log(x) - Li2_restricted (1-x) else if (abs(x) > 1.d0) then ! Li2 = 0 ! call msg_bug (" Dilogarithm called outside of defined range.") !!! Reactivate Dilogarithm identity Li2 = -pi2_6 - 0.5_default * log(-x) * log(-x) - Li2_restricted (1/x) else Li2 = Li2_restricted (x) end if contains elemental function Li2_restricted (x) result (Li2) real(double), intent(in) :: x real(double) :: Li2 real(double) :: tmp, z, z2 z = - log (1-x) z2 = z**2 ! Horner's rule for the powers z^3 through z^19 tmp = 43867._double/798._double tmp = tmp * z2 /342._double - 3617._double/510._double tmp = tmp * z2 /272._double + 7._double/6._double tmp = tmp * z2 /210._double - 691._double/2730._double tmp = tmp * z2 /156._double + 5._double/66._double tmp = tmp * z2 /110._double - 1._double/30._double tmp = tmp * z2 / 72._double + 1._double/42._double tmp = tmp * z2 / 42._double - 1._double/30._double tmp = tmp * z2 / 20._double + 1._double/6._double ! The first three terms of the power series Li2 = z2 * z * tmp / 6._double - 0.25_double * z2 + z end function Li2_restricted end function Li2_double @ %def Li2_double @ Complex digamma function. For this we use the asymptotic formula in Abramoqicz/Stegun, Eq. (6.3.18), and the recurrence formula Eq. (6.3.6): \begin{equation} \psi^{(0})(z) := \psi(z) = \frac{\Gamma'(z)}{\Gamma(z)} \end{equation} <>= public :: psic + public :: psir <>= elemental module function psic (z) result (psi) complex(default), intent(in) :: z complex(default) :: psi end function psic + elemental module function psir (x) result (psi) + real(default), intent(in) :: x + real(default) :: psi + end function psir <>= elemental module function psic (z) result (psi) complex(default), intent(in) :: z complex(default) :: psi complex(default) :: shift, zz, zi, zi2 shift = 0 zz = z if (abs (aimag(zz)) < 10._default) then do while (abs (zz) < 10._default) shift = shift - 1 / zz zz = zz + 1 end do end if zi = 1/zz zi2 = zi*zi psi = shift + log(zz) - zi/2 - zi2 / 5040._default * ( 420._default + & zi2 * ( -42._default + zi2 * (20._default - 21._default * zi2))) end function psic -@ %def psic + elemental module function psir (x) result (psi) + real(default), intent(in) :: x + real(default) :: psi + psi = real (psic (cmplx (x,0,kind=default)), kind=default) + end function psir + +@ %def psic psir @ Complex polygamma function. For this we use the asymptotic formula in Abramoqicz/Stegun, Eq. (6.4.11), and the recurrence formula Eq. (6.4.11): \begin{equation} \psi^{(m})(z) := \frac{d^m}{dz^m} \psi(z) = \frac{d^{m+1}}{dz^{m+1}} \ln \Gamma(z) \end{equation} <>= public :: psim + public :: psimr <>= elemental module function psim (z, m) result (psi) complex(default), intent(in) :: z integer, intent(in) :: m complex(default) :: psi end function psim + elemental module function psimr (x, m) result (psi) + real(default), intent(in) :: x + integer, intent(in) :: m + real(default) :: psi + end function psimr <>= elemental module function psim (z, m) result (psi) complex(default), intent(in) :: z integer, intent(in) :: m complex(default) :: psi complex(default) :: shift, rec, zz, zi, zi2 real(default) :: c1, c2, c3, c4, c5, c6, c7 integer :: i if (m < 1) then psi = psic(z) else shift = 0 zz = z if (abs (aimag (zz)) < 10._default) then - CHECK_ABS: do i = 1, m + CHECK_ABS: do rec = (-1)**m * factorial (m) / zz**(m+1) shift = shift - rec zz = zz + 1 if (abs (zz) > 10._default) exit CHECK_ABS end do CHECK_ABS end if c1 = 1._default c2 = 1._default / 2._default c3 = 1._default / 6._default c4 = - 1._default / 30._default c5 = 1._default / 42._default c6 = - 1._default / 30._default c7 = 5._default / 66._default do i = 2, m c1 = c1 * (i-1) c2 = c2 * i c3 = c3 * (i+1) c4 = c4 * (i+3) c5 = c5 * (i+5) c6 = c6 * (i+7) c7 = c7 * (i+9) end do zi = 1/zz zi2 = zi*zi psi = shift + (-1)**(m-1) * zi**m * ( c1 + zi * ( c2 + zi * ( & - c3 + zi2 * ( c4 + zi2 * ( c5 + zi2 * ( c6 + zi2 * ( c7 * zi2))))))) + c3 + zi2 * ( c4 + zi2 * ( c5 + zi2 * ( c6 + ( c7 * zi2))))))) end if end function psim -@ %def psim + elemental module function psimr (x, m) result (psi) + real(default), intent(in) :: x + integer, intent(in) :: m + real(default) :: psi + psi = real (psim (cmplx (x,0,kind=default), m), kind=default) + end function psimr + +@ %def psim psimr @ Nielsen's generalized polylogarithms, \begin{equation*} S_{n,m}(x) = \frac{(-1)^{n+m-1}}{(n-1)!m!} \int_0^1 t^{-1} \; \ln^{n-1} t \; \ln^m (1-xt) \; dt \; , \end{equation*} adapted from the CERNLIB function [[wgplg]] for real arguments [[x]] and integer $n$ and $m$ satisfying $1 \leq n \leq 4$, $1 \leq m \leq 4$, $n+m \leq 5$, i.e. one of the functions $S_{1,1}$, $S_{1,2}$, $S_{2,1}$, $S_{1,3}$, $S_{2,2}$, $S_{3,1}$, $S_{1,4}$, $S_{2,3}$, $S_{3,2}$, $S_{4,1}$. If $x\leq1$, $S_{n,m}(x)$ is real, and the imaginary part is set to zero. <>= public :: cnielsen public :: nielsen <>= module function cnielsen (n, m, x) result (nplog) integer, intent(in) :: n, m real(default), intent(in) :: x complex(default) :: nplog end function cnielsen module function nielsen (n, m, x) result (nplog) integer, intent(in) :: n, m real(default), intent(in) :: x real(default) :: nplog end function nielsen <>= module function cnielsen (n, m, x) result (nplog) integer, intent(in) :: n, m real(default), intent(in) :: x complex(default) :: nplog real(default), parameter :: c1 = 4._default/3._default, & c2 = 1._default/3._default real(default), dimension(0:4), parameter :: & fct = [1.0_default,1.0_default,2.0_default,6.0_default,24.0_default] real(default), dimension(4,4) :: s1, cc real(default), dimension(0:30,10) :: aa complex(default), dimension(0:5) :: vv real(default), dimension(0:5) :: uu real(default) :: x1, h, alfa, b0, b1, b2, qq, rr complex(default) :: sj, sk integer, dimension(10), parameter :: & nc = [24,26,28,30,22,24,26,19,22,17] integer, dimension(31), parameter :: & index = [1,2,3,4,0,0,0,0,0,0,5,6,7,0,0,0,0,0,0,0, & 8,9,0,0,0,0,0,0,0,0,10] real(default), dimension(0:4), parameter :: & sgn = [1._default, -1._default, 1._default, -1._default, 1._default] integer :: it, j, k, l, m1, n1 if ((n<1) .or. (n>4) .or. (m<1) .or. (m>4) .or. (n+m > 5)) then call msg_fatal & ("The Nielsen dilogarithms cannot be applied for these values.") end if s1 = 0._default s1(1,1) = 1.6449340668482_default s1(1,2) = 1.2020569031596_default s1(1,3) = 1.0823232337111_default s1(1,4) = 1.0369277551434_default s1(2,1) = 1.2020569031596_default s1(2,2) = 2.7058080842778e-1_default s1(2,3) = 9.6551159989444e-2_default s1(3,1) = 1.0823232337111_default s1(3,2) = 9.6551159989444e-2_default s1(4,1) = 1.0369277551434_default cc = 0._default cc(1,1) = 1.6449340668482_default cc(1,2) = 1.2020569031596_default cc(1,3) = 1.0823232337111_default cc(1,4) = 1.0369277551434_default cc(2,2) =-1.8940656589945_default cc(2,3) =-3.0142321054407_default cc(3,1) = 1.8940656589945_default cc(3,2) = 3.0142321054407_default aa = 0._default aa( 0,1) = 0.96753215043498_default aa( 1,1) = 0.16607303292785_default aa( 2,1) = 0.02487932292423_default aa( 3,1) = 0.00468636195945_default aa( 4,1) = 0.00100162749616_default aa( 5,1) = 0.00023200219609_default aa( 6,1) = 0.00005681782272_default aa( 7,1) = 0.00001449630056_default aa( 8,1) = 0.00000381632946_default aa( 9,1) = 0.00000102990426_default aa(10,1) = 0.00000028357538_default aa(11,1) = 0.00000007938705_default aa(12,1) = 0.00000002253670_default aa(13,1) = 0.00000000647434_default aa(14,1) = 0.00000000187912_default aa(15,1) = 0.00000000055029_default aa(16,1) = 0.00000000016242_default aa(17,1) = 0.00000000004827_default aa(18,1) = 0.00000000001444_default aa(19,1) = 0.00000000000434_default aa(20,1) = 0.00000000000131_default aa(21,1) = 0.00000000000040_default aa(22,1) = 0.00000000000012_default aa(23,1) = 0.00000000000004_default aa(24,1) = 0.00000000000001_default aa( 0,2) = 0.95180889127832_default aa( 1,2) = 0.43131131846532_default aa( 2,2) = 0.10002250714905_default aa( 3,2) = 0.02442415595220_default aa( 4,2) = 0.00622512463724_default aa( 5,2) = 0.00164078831235_default aa( 6,2) = 0.00044407920265_default aa( 7,2) = 0.00012277494168_default aa( 8,2) = 0.00003453981284_default aa( 9,2) = 0.00000985869565_default aa(10,2) = 0.00000284856995_default aa(11,2) = 0.00000083170847_default aa(12,2) = 0.00000024503950_default aa(13,2) = 0.00000007276496_default aa(14,2) = 0.00000002175802_default aa(15,2) = 0.00000000654616_default aa(16,2) = 0.00000000198033_default aa(17,2) = 0.00000000060204_default aa(18,2) = 0.00000000018385_default aa(19,2) = 0.00000000005637_default aa(20,2) = 0.00000000001735_default aa(21,2) = 0.00000000000536_default aa(22,2) = 0.00000000000166_default aa(23,2) = 0.00000000000052_default aa(24,2) = 0.00000000000016_default aa(25,2) = 0.00000000000005_default aa(26,2) = 0.00000000000002_default aa( 0,3) = 0.98161027991365_default aa( 1,3) = 0.72926806320726_default aa( 2,3) = 0.22774714909321_default aa( 3,3) = 0.06809083296197_default aa( 4,3) = 0.02013701183064_default aa( 5,3) = 0.00595478480197_default aa( 6,3) = 0.00176769013959_default aa( 7,3) = 0.00052748218502_default aa( 8,3) = 0.00015827461460_default aa( 9,3) = 0.00004774922076_default aa(10,3) = 0.00001447920408_default aa(11,3) = 0.00000441154886_default aa(12,3) = 0.00000135003870_default aa(13,3) = 0.00000041481779_default aa(14,3) = 0.00000012793307_default aa(15,3) = 0.00000003959070_default aa(16,3) = 0.00000001229055_default aa(17,3) = 0.00000000382658_default aa(18,3) = 0.00000000119459_default aa(19,3) = 0.00000000037386_default aa(20,3) = 0.00000000011727_default aa(21,3) = 0.00000000003687_default aa(22,3) = 0.00000000001161_default aa(23,3) = 0.00000000000366_default aa(24,3) = 0.00000000000116_default aa(25,3) = 0.00000000000037_default aa(26,3) = 0.00000000000012_default aa(27,3) = 0.00000000000004_default aa(28,3) = 0.00000000000001_default aa( 0,4) = 1.0640521184614_default aa( 1,4) = 1.0691720744981_default aa( 2,4) = 0.41527193251768_default aa( 3,4) = 0.14610332936222_default aa( 4,4) = 0.04904732648784_default aa( 5,4) = 0.01606340860396_default aa( 6,4) = 0.00518889350790_default aa( 7,4) = 0.00166298717324_default aa( 8,4) = 0.00053058279969_default aa( 9,4) = 0.00016887029251_default aa(10,4) = 0.00005368328059_default aa(11,4) = 0.00001705923313_default aa(12,4) = 0.00000542174374_default aa(13,4) = 0.00000172394082_default aa(14,4) = 0.00000054853275_default aa(15,4) = 0.00000017467795_default aa(16,4) = 0.00000005567550_default aa(17,4) = 0.00000001776234_default aa(18,4) = 0.00000000567224_default aa(19,4) = 0.00000000181313_default aa(20,4) = 0.00000000058012_default aa(21,4) = 0.00000000018579_default aa(22,4) = 0.00000000005955_default aa(23,4) = 0.00000000001911_default aa(24,4) = 0.00000000000614_default aa(25,4) = 0.00000000000197_default aa(26,4) = 0.00000000000063_default aa(27,4) = 0.00000000000020_default aa(28,4) = 0.00000000000007_default aa(29,4) = 0.00000000000002_default aa(30,4) = 0.00000000000001_default aa( 0,5) = 0.97920860669175_default aa( 1,5) = 0.08518813148683_default aa( 2,5) = 0.00855985222013_default aa( 3,5) = 0.00121177214413_default aa( 4,5) = 0.00020722768531_default aa( 5,5) = 0.00003996958691_default aa( 6,5) = 0.00000838064065_default aa( 7,5) = 0.00000186848945_default aa( 8,5) = 0.00000043666087_default aa( 9,5) = 0.00000010591733_default aa(10,5) = 0.00000002647892_default aa(11,5) = 0.00000000678700_default aa(12,5) = 0.00000000177654_default aa(13,5) = 0.00000000047342_default aa(14,5) = 0.00000000012812_default aa(15,5) = 0.00000000003514_default aa(16,5) = 0.00000000000975_default aa(17,5) = 0.00000000000274_default aa(18,5) = 0.00000000000077_default aa(19,5) = 0.00000000000022_default aa(20,5) = 0.00000000000006_default aa(21,5) = 0.00000000000002_default aa(22,5) = 0.00000000000001_default aa( 0,6) = 0.95021851963952_default aa( 1,6) = 0.29052529161433_default aa( 2,6) = 0.05081774061716_default aa( 3,6) = 0.00995543767280_default aa( 4,6) = 0.00211733895031_default aa( 5,6) = 0.00047859470550_default aa( 6,6) = 0.00011334321308_default aa( 7,6) = 0.00002784733104_default aa( 8,6) = 0.00000704788108_default aa( 9,6) = 0.00000182788740_default aa(10,6) = 0.00000048387492_default aa(11,6) = 0.00000013033842_default aa(12,6) = 0.00000003563769_default aa(13,6) = 0.00000000987174_default aa(14,6) = 0.00000000276586_default aa(15,6) = 0.00000000078279_default aa(16,6) = 0.00000000022354_default aa(17,6) = 0.00000000006435_default aa(18,6) = 0.00000000001866_default aa(19,6) = 0.00000000000545_default aa(20,6) = 0.00000000000160_default aa(21,6) = 0.00000000000047_default aa(22,6) = 0.00000000000014_default aa(23,6) = 0.00000000000004_default aa(24,6) = 0.00000000000001_default aa( 0,7) = 0.95064032186777_default aa( 1,7) = 0.54138285465171_default aa( 2,7) = 0.13649979590321_default aa( 3,7) = 0.03417942328207_default aa( 4,7) = 0.00869027883583_default aa( 5,7) = 0.00225284084155_default aa( 6,7) = 0.00059516089806_default aa( 7,7) = 0.00015995617766_default aa( 8,7) = 0.00004365213096_default aa( 9,7) = 0.00001207474688_default aa(10,7) = 0.00000338018176_default aa(11,7) = 0.00000095632476_default aa(12,7) = 0.00000027313129_default aa(13,7) = 0.00000007866968_default aa(14,7) = 0.00000002283195_default aa(15,7) = 0.00000000667205_default aa(16,7) = 0.00000000196191_default aa(17,7) = 0.00000000058018_default aa(18,7) = 0.00000000017246_default aa(19,7) = 0.00000000005151_default aa(20,7) = 0.00000000001545_default aa(21,7) = 0.00000000000465_default aa(22,7) = 0.00000000000141_default aa(23,7) = 0.00000000000043_default aa(24,7) = 0.00000000000013_default aa(25,7) = 0.00000000000004_default aa(26,7) = 0.00000000000001_default aa( 0,8) = 0.98800011672229_default aa( 1,8) = 0.04364067609601_default aa( 2,8) = 0.00295091178278_default aa( 3,8) = 0.00031477809720_default aa( 4,8) = 0.00004314846029_default aa( 5,8) = 0.00000693818230_default aa( 6,8) = 0.00000124640350_default aa( 7,8) = 0.00000024293628_default aa( 8,8) = 0.00000005040827_default aa( 9,8) = 0.00000001099075_default aa(10,8) = 0.00000000249467_default aa(11,8) = 0.00000000058540_default aa(12,8) = 0.00000000014127_default aa(13,8) = 0.00000000003492_default aa(14,8) = 0.00000000000881_default aa(15,8) = 0.00000000000226_default aa(16,8) = 0.00000000000059_default aa(17,8) = 0.00000000000016_default aa(18,8) = 0.00000000000004_default aa(19,8) = 0.00000000000001_default aa( 0,9) = 0.95768506546350_default aa( 1,9) = 0.19725249679534_default aa( 2,9) = 0.02603370313918_default aa( 3,9) = 0.00409382168261_default aa( 4,9) = 0.00072681707110_default aa( 5,9) = 0.00014091879261_default aa( 6,9) = 0.00002920458914_default aa( 7,9) = 0.00000637631144_default aa( 8,9) = 0.00000145167850_default aa( 9,9) = 0.00000034205281_default aa(10,9) = 0.00000008294302_default aa(11,9) = 0.00000002060784_default aa(12,9) = 0.00000000522823_default aa(13,9) = 0.00000000135066_default aa(14,9) = 0.00000000035451_default aa(15,9) = 0.00000000009436_default aa(16,9) = 0.00000000002543_default aa(17,9) = 0.00000000000693_default aa(18,9) = 0.00000000000191_default aa(19,9) = 0.00000000000053_default aa(20,9) = 0.00000000000015_default aa(21,9) = 0.00000000000004_default aa(22,9) = 0.00000000000001_default aa( 0,10) = 0.99343651671347_default aa( 1,10) = 0.02225770126826_default aa( 2,10) = 0.00101475574703_default aa( 3,10) = 0.00008175156250_default aa( 4,10) = 0.00000899973547_default aa( 5,10) = 0.00000120823987_default aa( 6,10) = 0.00000018616913_default aa( 7,10) = 0.00000003174723_default aa( 8,10) = 0.00000000585215_default aa( 9,10) = 0.00000000114739_default aa(10,10) = 0.00000000023652_default aa(11,10) = 0.00000000005082_default aa(12,10) = 0.00000000001131_default aa(13,10) = 0.00000000000259_default aa(14,10) = 0.00000000000061_default aa(15,10) = 0.00000000000015_default aa(16,10) = 0.00000000000004_default aa(17,10) = 0.00000000000001_default if (x == 1._default) then nplog = s1(n,m) else if (x > 2._default .or. x < -1.0_default) then x1 = 1._default / x h = c1 * x1 + c2 alfa = h + h vv(0) = 1._default if (x < -1.0_default) then vv(1) = log(-x) else if (x > 2._default) then vv(1) = log(cmplx(-x,0._default,kind=default)) end if do l = 2, n+m vv(l) = vv(1) * vv(l-1)/l end do sk = 0._default do k = 0, m-1 m1 = m-k rr = x1**m1 / (fct(m1) * fct(n-1)) sj = 0._default do j = 0, k n1 = n+k-j l = index(10*n1+m1-10) b1 = 0._default b2 = 0._default do it = nc(l), 0, -1 b0 = aa(it,l) + alfa*b1 - b2 b2 = b1 b1 = b0 end do qq = (fct(n1-1) / fct(k-j)) * (b0 - h*b2) * rr / m1**n1 sj = sj + vv(j) * qq end do sk = sk + sgn(k) * sj end do sj = 0._default do j = 0, n-1 sj = sj + vv(j) * cc(n-j,m) end do nplog = sgn(n) * sk + sgn(m) * (sj + vv(n+m)) else if (x > 0.5_default) then x1 = 1._default - x h = c1 * x1 + c2 alfa = h + h vv(0) = 1._default uu(0) = 1._default vv(1) = log(cmplx(x1,0._default,kind=default)) uu(1) = log(x) do l = 2, m vv(l) = vv(1) * vv(l-1) / l end do do l = 2, n uu(l) = uu(1) * uu(l-1) / l end do sk = 0._default do k = 0, n-1 m1 = n-k rr = x1**m1 / fct(m1) sj = 0._default do j = 0, m-1 n1 = m-j l = index(10*n1 + m1 - 10) b1 = 0._default b2 = 0._default do it = nc(l), 0, -1 b0 = aa(it,l) + alfa*b1 - b2 b2 = b1 b1 = b0 end do qq = sgn(j) * (b0 - h*b2) * rr / m1**n1 sj = sj + vv(j) * qq end do sk = sk + uu(k) * (s1(m1,m) - sj) end do nplog = sk + sgn(m) * uu(n) * vv(m) else l = index(10*n + m - 10) h = c1 * x + c2 alfa = h + h b1 = 0._default b2 = 0._default do it = nc(l), 0, -1 b0 = aa(it,l) + alfa*b1 - b2 b2 = b1 b1 = b0 end do nplog = (b0 - h*b2) * x**m / (fct(m) * m**n) end if end function cnielsen module function nielsen (n, m, x) result (nplog) integer, intent(in) :: n, m real(default), intent(in) :: x real(default) :: nplog nplog = real (cnielsen (n, m, x)) end function nielsen @ %def cnielsen nielsen @ $\text{Li}_{n}(x) = S_{n-1,1}(x)$. <>= public :: polylog <>= module function polylog (n, x) result (plog) integer, intent(in) :: n real(default), intent(in) :: x real(default) :: plog end function polylog <>= module function polylog (n, x) result (plog) integer, intent(in) :: n real(default), intent(in) :: x real(default) :: plog plog = nielsen (n-1,1,x) end function polylog @ %def polylog @ $\text{Li}_2(x)$. <>= public :: dilog <>= module function dilog (x) result (dlog) real(default), intent(in) :: x real(default) :: dlog end function dilog <>= module function dilog (x) result (dlog) real(default), intent(in) :: x real(default) :: dlog dlog = polylog (2,x) end function dilog @ %def dilog @ $\text{Li}_3(x)$. <>= public :: trilog <>= module function trilog (x) result (tlog) real(default), intent(in) :: x real(default) :: tlog end function trilog <>= module function trilog (x) result (tlog) real(default), intent(in) :: x real(default) :: tlog tlog = polylog (3,x) end function trilog @ %def trilog @ \subsection{Loop Integrals} These functions appear in the calculation of the effective one-loop coupling of a (pseudo)scalar to a vector boson pair. <>= public :: faux <>= elemental module function faux (x) result (y) real(default), intent(in) :: x complex(default) :: y end function faux <>= elemental module function faux (x) result (y) real(default), intent(in) :: x complex(default) :: y if (1 <= x) then y = asin(sqrt(1/x))**2 else y = - 1/4.0_default * (log((1 + sqrt(1 - x))/ & (1 - sqrt(1 - x))) - cmplx (0.0_default, pi, kind=default))**2 end if end function faux @ %def faux @ <>= public :: fonehalf <>= elemental module function fonehalf (x) result (y) real(default), intent(in) :: x complex(default) :: y end function fonehalf <>= elemental module function fonehalf (x) result (y) real(default), intent(in) :: x complex(default) :: y if (abs(x) < eps0) then y = 0 else y = - 2.0_default * x * (1 + (1 - x) * faux(x)) end if end function fonehalf @ %def fonehalf @ <>= public :: fonehalf_pseudo <>= module function fonehalf_pseudo (x) result (y) real(default), intent(in) :: x complex(default) :: y end function fonehalf_pseudo <>= module function fonehalf_pseudo (x) result (y) real(default), intent(in) :: x complex(default) :: y if (abs(x) < eps0) then y = 0 else y = - 2.0_default * x * faux(x) end if end function fonehalf_pseudo @ %def fonehalf_pseudo @ <>= public :: fone <>= elemental module function fone (x) result (y) real(default), intent(in) :: x complex(default) :: y end function fone <>= elemental module function fone (x) result (y) real(default), intent(in) :: x complex(default) :: y if (abs(x) < eps0) then y = 2.0_default else y = 2.0_default + 3.0_default * x + & 3.0_default * x * (2.0_default - x) * & faux(x) end if end function fone @ %def fone @ <>= public :: gaux <>= elemental module function gaux (x) result (y) real(default), intent(in) :: x complex(default) :: y end function gaux <>= elemental module function gaux (x) result (y) real(default), intent(in) :: x complex(default) :: y if (1 <= x) then y = sqrt(x - 1) * asin(sqrt(1/x)) else y = sqrt(1 - x) * (log((1 + sqrt(1 - x)) / & (1 - sqrt(1 - x))) - & cmplx (0.0_default, pi, kind=default)) / 2.0_default end if end function gaux @ %def gaux @ <>= public :: tri_i1 <>= elemental module function tri_i1 (a,b) result (y) real(default), intent(in) :: a,b complex(default) :: y end function tri_i1 <>= elemental module function tri_i1 (a,b) result (y) real(default), intent(in) :: a,b complex(default) :: y if (a < eps0 .or. b < eps0) then y = 0 else y = a*b/2.0_default/(a-b) + a**2 * b**2/2.0_default/(a-b)**2 * & (faux(a) - faux(b)) + & a**2 * b/(a-b)**2 * (gaux(a) - gaux(b)) end if end function tri_i1 @ %def tri_i1 @ <>= public :: tri_i2 <>= elemental module function tri_i2 (a,b) result (y) real(default), intent(in) :: a,b complex(default) :: y end function tri_i2 <>= elemental module function tri_i2 (a,b) result (y) real(default), intent(in) :: a,b complex(default) :: y if (a < eps0 .or. b < eps0) then y = 0 else y = - a * b / 2.0_default / (a-b) * (faux(a) - faux(b)) end if end function tri_i2 @ %def tri_i2 @ \subsection{More on $\alpha_s$} These functions are for the running of the strong coupling constants, $\alpha_s$. <>= public :: run_b0 <>= elemental module function run_b0 (nf) result (bnull) integer, intent(in) :: nf real(default) :: bnull end function run_b0 <>= elemental module function run_b0 (nf) result (bnull) integer, intent(in) :: nf real(default) :: bnull bnull = 33.0_default - 2.0_default * nf end function run_b0 @ %def run_b0 @ <>= public :: run_b1 <>= elemental module function run_b1 (nf) result (bone) integer, intent(in) :: nf real(default) :: bone end function run_b1 <>= elemental module function run_b1 (nf) result (bone) integer, intent(in) :: nf real(default) :: bone bone = 6.0_default * (153.0_default - 19.0_default * nf)/run_b0(nf)**2 end function run_b1 @ %def run_b1 @ <>= public :: run_aa <>= elemental module function run_aa (nf) result (aaa) integer, intent(in) :: nf real(default) :: aaa end function run_aa <>= elemental module function run_aa (nf) result (aaa) integer, intent(in) :: nf real(default) :: aaa aaa = 12.0_default * PI / run_b0(nf) end function run_aa @ %def run_aa @ <>= public :: run_bb <>= elemental function run_bb (nf) result (bbb) integer, intent(in) :: nf real(default) :: bbb bbb = run_b1(nf) / run_aa(nf) end function run_bb @ %def run_bb @ \subsection{Functions for Catani-Seymour dipoles} For the automated Catani-Seymour dipole subtraction, we need the following functions. <>= public :: ff_dipole <>= pure module subroutine ff_dipole (v_ijk, y_ijk, p_ij, pp_k, p_i, p_j, p_k) type(vector4_t), intent(in) :: p_i, p_j, p_k type(vector4_t), intent(out) :: p_ij, pp_k real(default), intent(out) :: y_ijk real(default), intent(out) :: v_ijk end subroutine ff_dipole <>= pure module subroutine ff_dipole (v_ijk, y_ijk, p_ij, pp_k, p_i, p_j, p_k) type(vector4_t), intent(in) :: p_i, p_j, p_k type(vector4_t), intent(out) :: p_ij, pp_k real(default), intent(out) :: y_ijk real(default) :: z_i real(default), intent(out) :: v_ijk z_i = (p_i*p_k) / ((p_k*p_j) + (p_k*p_i)) y_ijk = (p_i*p_j) / ((p_i*p_j) + (p_i*p_k) + (p_j*p_k)) p_ij = p_i + p_j - y_ijk/(1.0_default - y_ijk) * p_k pp_k = (1.0/(1.0_default - y_ijk)) * p_k !!! We don't multiply by alpha_s right here: v_ijk = 8.0_default * PI * CF * & (2.0 / (1.0 - z_i*(1.0 - y_ijk)) - (1.0 + z_i)) end subroutine ff_dipole @ %def ff_dipole @ <>= public :: fi_dipole <>= pure module subroutine fi_dipole (v_ija, x_ija, p_ij, pp_a, p_i, p_j, p_a) type(vector4_t), intent(in) :: p_i, p_j, p_a type(vector4_t), intent(out) :: p_ij, pp_a real(default), intent(out) :: x_ija real(default), intent(out) :: v_ija end subroutine fi_dipole <>= pure module subroutine fi_dipole (v_ija, x_ija, p_ij, pp_a, p_i, p_j, p_a) type(vector4_t), intent(in) :: p_i, p_j, p_a type(vector4_t), intent(out) :: p_ij, pp_a real(default), intent(out) :: x_ija real(default) :: z_i real(default), intent(out) :: v_ija z_i = (p_i*p_a) / ((p_a*p_j) + (p_a*p_i)) x_ija = ((p_i*p_a) + (p_j*p_a) - (p_i*p_j)) & / ((p_i*p_a) + (p_j*p_a)) p_ij = p_i + p_j - (1.0_default - x_ija) * p_a pp_a = x_ija * p_a !!! We don't not multiply by alpha_s right here: v_ija = 8.0_default * PI * CF * & (2.0 / (1.0 - z_i + (1.0 - x_ija)) - (1.0 + z_i)) / x_ija end subroutine fi_dipole @ %def fi_dipole @ <>= public :: if_dipole <>= pure module subroutine if_dipole (v_kja, u_j, p_aj, pp_k, p_k, p_j, p_a) type(vector4_t), intent(in) :: p_k, p_j, p_a type(vector4_t), intent(out) :: p_aj, pp_k real(default), intent(out) :: u_j real(default), intent(out) :: v_kja end subroutine if_dipole <>= pure module subroutine if_dipole (v_kja, u_j, p_aj, pp_k, p_k, p_j, p_a) type(vector4_t), intent(in) :: p_k, p_j, p_a type(vector4_t), intent(out) :: p_aj, pp_k real(default), intent(out) :: u_j real(default) :: x_kja real(default), intent(out) :: v_kja u_j = (p_a*p_j) / ((p_a*p_j) + (p_a*p_k)) x_kja = ((p_a*p_k) + (p_a*p_j) - (p_j*p_k)) & / ((p_a*p_j) + (p_a*p_k)) p_aj = x_kja * p_a pp_k = p_k + p_j - (1.0_default - x_kja) * p_a v_kja = 8.0_default * PI * CF * & (2.0 / (1.0 - x_kja + u_j) - (1.0 + x_kja)) / x_kja end subroutine if_dipole @ %def if_dipole @ This function depends on a variable number of final state particles whose kinematics all get changed by the initial-initial dipole insertion. <>= public :: ii_dipole <>= pure module subroutine ii_dipole (v_jab, v_j, p_in, p_out, flag_1or2) type(vector4_t), dimension(:), intent(in) :: p_in type(vector4_t), dimension(size(p_in)-1), intent(out) :: p_out logical, intent(in) :: flag_1or2 real(default), intent(out) :: v_j real(default), intent(out) :: v_jab end subroutine ii_dipole <>= pure module subroutine ii_dipole (v_jab, v_j, p_in, p_out, flag_1or2) type(vector4_t), dimension(:), intent(in) :: p_in type(vector4_t), dimension(size(p_in)-1), intent(out) :: p_out logical, intent(in) :: flag_1or2 real(default), intent(out) :: v_j real(default), intent(out) :: v_jab type(vector4_t) :: p_a, p_b, p_j type(vector4_t) :: k, kk type(vector4_t) :: p_aj real(default) :: x_jab integer :: i !!! flag_1or2 decides whether this a 12 or 21 dipole if (flag_1or2) then p_a = p_in(1) p_b = p_in(2) else p_b = p_in(1) p_a = p_in(2) end if !!! We assume that the unresolved particle has always the last !!! momentum p_j = p_in(size(p_in)) x_jab = ((p_a*p_b) - (p_a*p_j) - (p_b*p_j)) / (p_a*p_b) v_j = (p_a*p_j) / (p_a * p_b) p_aj = x_jab * p_a k = p_a + p_b - p_j kk = p_aj + p_b do i = 3, size(p_in)-1 p_out(i) = p_in(i) - 2.0*((k+kk)*p_in(i))/((k+kk)*(k+kk)) * (k+kk) + & (2.0 * (k*p_in(i)) / (k*k)) * kk end do if (flag_1or2) then p_out(1) = p_aj p_out(2) = p_b else p_out(1) = p_b p_out(2) = p_aj end if v_jab = 8.0_default * PI * CF * & (2.0 / (1.0 - x_jab) - (1.0 + x_jab)) / x_jab end subroutine ii_dipole @ %def ii_dipole @ \subsection{Distributions for integrated dipoles and such} Note that the following formulae are only meaningful for $0 \leq x \leq 1$. The Dirac delta distribution, modified for Monte-Carlo sampling, centered at $x=1-\frac{\epsilon}{2}$: <>= public :: delta <>= elemental module function delta (x,eps) result (z) real(default), intent(in) :: x, eps real(default) :: z end function delta <>= elemental module function delta (x,eps) result (z) real(default), intent(in) :: x, eps real(default) :: z if (x > one - eps) then z = one / eps else z = 0 end if end function delta @ %def delta @ The $+$-distribution, $P_+(x) = \left( \frac{1}{1-x}\right)_+$, for the regularization of soft-collinear singularities. The constant part for the Monte-Carlo sampling is the integral over the splitting function divided by the weight for the WHIZARD numerical integration over the interval. <>= public :: plus_distr <>= elemental module function plus_distr (x,eps) result (plusd) real(default), intent(in) :: x, eps real(default) :: plusd end function plus_distr <>= elemental module function plus_distr (x,eps) result (plusd) real(default), intent(in) :: x, eps real(default) :: plusd if (x > one - eps) then plusd = log(eps) / eps else plusd = one / (one - x) end if end function plus_distr @ %def plus_distr @ The splitting function in $D=4$ dimensions, regularized as $+$-distributions if necessary: \begin{align} P^{qq} (x) = P^{\bar q\bar q} (x) &= \; C_F \cdot \left( \frac{1 + x^2}{1-x} \right)_+ \\ P^{qg} (x) = P^{\bar q g} (x) &= \; C_F \cdot \frac{1 + (1-x)^2}{x}\\ P^{gq} (x) = P^{g \bar q} (x) &= \; T_R \cdot \left[ x^2 + (1-x)^2 \right] \\ P^{gg} (x) &= \; 2 C_A \biggl[ \left( \frac{1}{1-x} \right)_+ + \frac{1-x}{x} - 1 + x(1-x) \biggl] \notag{}\\ &\quad + \delta(1-x) \left( \frac{11}{6} C_A - \frac{2}{3} N_f T_R \right) \end{align} Since the number of flavors summed over in the gluon splitting function might depend on the physics case under consideration, it is implemented as an input variable. <>= public :: pqq <>= elemental module function pqq (x,eps) result (pqqx) real(default), intent(in) :: x, eps real(default) :: pqqx end function pqq <>= elemental module function pqq (x,eps) result (pqqx) real(default), intent(in) :: x, eps real(default) :: pqqx if (x > (1.0_default - eps)) then pqqx = (eps - one) / two + two * log(eps) / eps - & three * (eps - one) / eps / two else pqqx = (one + x**2) / (one - x) end if pqqx = CF * pqqx end function pqq @ %def pqq @ <>= public :: pgq <>= elemental module function pgq (x) result (pgqx) real(default), intent(in) :: x real(default) :: pgqx end function pgq <>= elemental module function pgq (x) result (pgqx) real(default), intent(in) :: x real(default) :: pgqx pgqx = TR * (x**2 + (one - x)**2) end function pgq @ %def pgq @ <>= public :: pqg <>= elemental module function pqg (x) result (pqgx) real(default), intent(in) :: x real(default) :: pqgx end function pqg <>= elemental module function pqg (x) result (pqgx) real(default), intent(in) :: x real(default) :: pqgx pqgx = CF * (one + (one - x)**2) / x end function pqg @ %def pqg @ <>= public :: pgg <>= elemental module function pgg (x, nf, eps) result (pggx) real(default), intent(in) :: x, nf, eps real(default) :: pggx end function pgg <>= elemental module function pgg (x, nf, eps) result (pggx) real(default), intent(in) :: x, nf, eps real(default) :: pggx pggx = two * CA * ( plus_distr (x, eps) + (one-x)/x - one + & x*(one-x)) + delta (x, eps) * gamma_g(nf) end function pgg @ %def pgg @ For the $qq$ and $gg$ cases, there exist ``regularized'' versions of the splitting functions: \begin{align} P^{qq}_{\text{reg}} (x) &= - C_F \cdot (1 + x) \\ P^{gg}_{\text{reg}} (x) &= 2 C_A \left[ \frac{1-x}{x} - 1 + x(1-x) \right] \end{align} <>= public :: pqq_reg <>= elemental module function pqq_reg (x) result (pqqregx) real(default), intent(in) :: x real(default) :: pqqregx end function pqq_reg <>= elemental module function pqq_reg (x) result (pqqregx) real(default), intent(in) :: x real(default) :: pqqregx pqqregx = - CF * (one + x) end function pqq_reg @ %def pqq_reg @ <>= public :: pgg_reg <>= elemental module function pgg_reg (x) result (pggregx) real(default), intent(in) :: x real(default) :: pggregx end function pgg_reg <>= elemental module function pgg_reg (x) result (pggregx) real(default), intent(in) :: x real(default) :: pggregx pggregx = two * CA * ((one - x)/x - one + x*(one - x)) end function pgg_reg @ %def pgg_reg @ Here, we collect the expressions needed for integrated Catani-Seymour dipoles, and the so-called flavor kernels. We always distinguish between the ``ordinary'' Catani-Seymour version, and the one including a phase-space slicing parameter, $\alpha$. The standard flavor kernels $\overline{K}^{ab}$ are: \begin{align} \overline{K}^{qg} (x) = \overline{K}^{\bar q g} (x) & = \; P^{qg} (x) \log ((1-x)/x) + CF \times x \\ %%% \overline{K}^{gq} (x) = \overline{K}^{g \bar q} (x) & = \; P^{gq} (x) \log ((1-x)/x) + TR \times 2x(1-x) \\ %%% \overline{K}^{qq} &=\; C_F \biggl[ \left( \frac{2}{1-x} \log \frac{1-x}{x} \right)_+ - (1+x) \log ((1-x)/x) + (1-x) \biggr] \notag{}\\ &\quad - (5 - \pi^2) \cdot C_F \cdot \delta(1-x) \\ %%% \overline{K}^{gg} &=\; 2 C_A \biggl[ \left( \frac{1}{1-x} \log \frac{1-x}{x} \right)_+ + \left( \frac{1-x}{x} - 1 + x(1-x) \right) \log((1-x)/x) \biggr] \notag{}\\ &\quad - \delta(1-x) \biggl[ \left( \frac{50}{9} - \pi^2 \right) C_A - \frac{16}{9} T_R N_f \biggr] \end{align} <>= public :: kbarqg <>= module function kbarqg (x) result (kbarqgx) real(default), intent(in) :: x real(default) :: kbarqgx end function kbarqg <>= module function kbarqg (x) result (kbarqgx) real(default), intent(in) :: x real(default) :: kbarqgx kbarqgx = pqg(x) * log((one-x)/x) + CF * x end function kbarqg @ %def kbarqg @ <>= public :: kbargq <>= module function kbargq (x) result (kbargqx) real(default), intent(in) :: x real(default) :: kbargqx end function kbargq <>= module function kbargq (x) result (kbargqx) real(default), intent(in) :: x real(default) :: kbargqx kbargqx = pgq(x) * log((one-x)/x) + two * TR * x * (one - x) end function kbargq @ %def kbarqg @ <>= public :: kbarqq <>= module function kbarqq (x,eps) result (kbarqqx) real(default), intent(in) :: x, eps real(default) :: kbarqqx end function kbarqq <>= module function kbarqq (x,eps) result (kbarqqx) real(default), intent(in) :: x, eps real(default) :: kbarqqx kbarqqx = CF*(log_plus_distr(x,eps) - (one+x) * log((one-x)/x) + (one - & x) - (five - pi**2) * delta(x,eps)) end function kbarqq @ %def kbarqq @ <>= public :: kbargg <>= module function kbargg (x,eps,nf) result (kbarggx) real(default), intent(in) :: x, eps, nf real(default) :: kbarggx end function kbargg <>= module function kbargg (x,eps,nf) result (kbarggx) real(default), intent(in) :: x, eps, nf real(default) :: kbarggx kbarggx = CA * (log_plus_distr(x,eps) + two * ((one-x)/x - one + & x*(one-x) * log((1-x)/x))) - delta(x,eps) * & ((50.0_default/9.0_default - pi**2) * CA - & 16.0_default/9.0_default * TR * nf) end function kbargg @ %def kbargg @ The $\tilde{K}$ are used when two identified hadrons participate: \begin{equation} \tilde{K}^{ab} (x) = P^{ab}_{\text{reg}} (x) \cdot \log (1-x) + \delta^{ab} \mathbf{T}_a^2 \biggl[ \left( \frac{2}{1-x} \log (1-x) \right)_+ - \frac{\pi^2}{3} \delta(1-x) \biggr] \end{equation} <>= public :: ktildeqq <>= module function ktildeqq (x,eps) result (ktildeqqx) real(default), intent(in) :: x, eps real(default) :: ktildeqqx end function ktildeqq <>= module function ktildeqq (x,eps) result (ktildeqqx) real(default), intent(in) :: x, eps real(default) :: ktildeqqx ktildeqqx = pqq_reg (x) * log(one-x) + CF * ( - log2_plus_distr (x,eps) & - pi**2/three * delta(x,eps)) end function ktildeqq @ %def ktildeqq @ <>= public :: ktildeqg <>= module function ktildeqg (x,eps) result (ktildeqgx) real(default), intent(in) :: x, eps real(default) :: ktildeqgx end function ktildeqg <>= module function ktildeqg (x,eps) result (ktildeqgx) real(default), intent(in) :: x, eps real(default) :: ktildeqgx ktildeqgx = pqg (x) * log(one-x) end function ktildeqg @ %def ktildeqg @ <>= public :: ktildegq <>= module function ktildegq (x,eps) result (ktildegqx) real(default), intent(in) :: x, eps real(default) :: ktildegqx end function ktildegq <>= module function ktildegq (x,eps) result (ktildegqx) real(default), intent(in) :: x, eps real(default) :: ktildegqx ktildegqx = pgq (x) * log(one-x) end function ktildegq @ %def ktildeqg @ <>= public :: ktildegg <>= module function ktildegg (x,eps) result (ktildeggx) real(default), intent(in) :: x, eps real(default) :: ktildeggx end function ktildegg <>= module function ktildegg (x,eps) result (ktildeggx) real(default), intent(in) :: x, eps real(default) :: ktildeggx ktildeggx = pgg_reg (x) * log(one-x) + CA * ( - & log2_plus_distr (x,eps) - pi**2/three * delta(x,eps)) end function ktildegg @ %def ktildegg @ The insertion operator might not be necessary for a GOLEM interface but is demanded by the Les Houches NLO accord. It is a three-dimensional array, where the index always gives the inverse power of the DREG expansion parameter, $\epsilon$. <>= public :: insert_q <>= pure module function insert_q () result (i_q) real(default), dimension(0:2) :: i_q end function insert_q <>= pure module function insert_q () result (i_q) real(default), dimension(0:2) :: i_q i_q(0) = gamma_q + k_q - pi**2/three * CF i_q(1) = gamma_q i_q(2) = CF end function insert_q @ %def insert_q @ <>= public :: insert_g <>= pure module function insert_g (nf) result (i_g) real(default), intent(in) :: nf real(default), dimension(0:2) :: i_g end function insert_g <>= pure module function insert_g (nf) result (i_g) real(default), intent(in) :: nf real(default), dimension(0:2) :: i_g i_g(0) = gamma_g (nf) + k_g (nf) - pi**2/three * CA i_g(1) = gamma_g (nf) i_g(2) = CA end function insert_g @ %def insert_g @ For better convergence, one can exclude regions of phase space with a slicing parameter from the dipole subtraction procedure. First of all, the $K$ functions get modified: \begin{equation} K_i (\alpha) = K_i - \mathbf{T}_i^2 \log^2 \alpha + \gamma_i ( \alpha - 1 - \log\alpha) \end{equation} <>= public :: k_q_al, k_g_al <>= pure module function k_q_al (alpha) real(default), intent(in) :: alpha real(default) :: k_q_al end function k_q_al pure module function k_g_al (alpha, nf) real(default), intent(in) :: alpha, nf real(default) :: k_g_al end function k_g_al <>= pure module function k_q_al (alpha) real(default), intent(in) :: alpha real(default) :: k_q_al k_q_al = k_q - CF * (log(alpha))**2 + gamma_q * & (alpha - one - log(alpha)) end function k_q_al pure module function k_g_al (alpha, nf) real(default), intent(in) :: alpha, nf real(default) :: k_g_al k_g_al = k_g (nf) - CA * (log(alpha))**2 + gamma_g (nf) * & (alpha - one - log(alpha)) end function k_g_al @ %def k_q_al @ %def k_g_al @ The $+$-distribution, but with a phase-space slicing parameter, $\alpha$, $P_{1-\alpha}(x) = \left( \frac{1}{1-x} \right)_{1-x}$. Since we need the fatal error message here, this function cannot be elemental. <>= public :: plus_distr_al <>= module function plus_distr_al (x,alpha,eps) result (plusd_al) real(default), intent(in) :: x, eps, alpha real(default) :: plusd_al end function plus_distr_al <>= module function plus_distr_al (x,alpha,eps) result (plusd_al) real(default), intent(in) :: x, eps, alpha real(default) :: plusd_al if ((one - alpha) >= (one - eps)) then plusd_al = zero call msg_fatal ('sm_physics, plus_distr_al: alpha and epsilon chosen wrongly') elseif (x < (1.0_default - alpha)) then plusd_al = 0 else if (x > (1.0_default - eps)) then plusd_al = log(eps/alpha)/eps else plusd_al = one/(one-x) end if end function plus_distr_al @ %def plus_distr_al @ Introducing phase-space slicing parameters, these standard flavor kernels $\overline{K}^{ab}$ become: \begin{align} \overline{K}^{qg}_\alpha (x) = \overline{K}^{\bar q g}_\alpha (x) & = \; P^{qg} (x) \log (\alpha (1-x)/x) + C_F \times x \\ %%% \overline{K}^{gq}_\alpha (x) = \overline{K}^{g \bar q}_\alpha (x) & = \; P^{gq} (x) \log (\alpha (1-x)/x) + T_R \times 2x(1-x) \\ %%% \overline{K}^{qq}_\alpha &= C_F (1 - x) + P^{qq}_{\text{reg}} (x) \log \frac{\alpha(1-x)}{x} \notag{}\\ &\quad + C_F \delta (1 - x) \log^2 \alpha + C_F \left( \frac{2}{1-x} \log \frac{1-x}{x} \right)_+ \notag{}\\ &\quad - \left( \gamma_q + K_q(\alpha) - \frac56 \pi^2 C_F \right) \cdot \delta(1-x) \; C_F \Bigl[ + \frac{2}{1-x} \log \left( \frac{\alpha (2-x)}{1+\alpha-x} \right) - \theta(1 - \alpha - x) \cdot \left( \frac{2}{1-x} \log \frac{2-x}{1-x} \right) \Bigr] \\ %%% \overline{K}^{gg}_\alpha &=\; P^{gg}_{\text{reg}} (x) \log \frac{\alpha(1-x)}{x} + C_A \delta (1 - x) \log^2 \alpha \notag{}\\ &\quad + C_A \left( \frac{2}{1-x} \log \frac{1-x}{x} \right)_+ - \left( \gamma_g + K_g(\alpha) - \frac56 \pi^2 C_A \right) \cdot \delta(1-x) \; C_A \Bigl[ + \frac{2}{1-x} \log \left( \frac{\alpha (2-x)}{1+\alpha-x} \right) - \theta(1 - \alpha - x) \cdot \left( \frac{2}{1-x} \log \frac{2-x}{1-x} \right) \Bigr] \end{align} <>= public :: kbarqg_al <>= module function kbarqg_al (x,alpha,eps) result (kbarqgx) real(default), intent(in) :: x, alpha, eps real(default) :: kbarqgx end function kbarqg_al <>= module function kbarqg_al (x,alpha,eps) result (kbarqgx) real(default), intent(in) :: x, alpha, eps real(default) :: kbarqgx kbarqgx = pqg (x) * log(alpha*(one-x)/x) + CF * x end function kbarqg_al @ %def kbarqg_al @ <>= public :: kbargq_al <>= module function kbargq_al (x,alpha,eps) result (kbargqx) real(default), intent(in) :: x, alpha, eps real(default) :: kbargqx end function kbargq_al <>= module function kbargq_al (x,alpha,eps) result (kbargqx) real(default), intent(in) :: x, alpha, eps real(default) :: kbargqx kbargqx = pgq (x) * log(alpha*(one-x)/x) + two * TR * x * (one-x) end function kbargq_al @ %def kbargq_al @ <>= public :: kbarqq_al <>= module function kbarqq_al (x,alpha,eps) result (kbarqqx) real(default), intent(in) :: x, alpha, eps real(default) :: kbarqqx end function kbarqq_al <>= module function kbarqq_al (x,alpha,eps) result (kbarqqx) real(default), intent(in) :: x, alpha, eps real(default) :: kbarqqx kbarqqx = CF * (one - x) + pqq_reg(x) * log(alpha*(one-x)/x) & + CF * log_plus_distr(x,eps) & - (gamma_q + k_q_al(alpha) - CF * & five/6.0_default * pi**2 - CF * (log(alpha))**2) * & delta(x,eps) + & CF * two/(one -x)*log(alpha*(two-x)/(one+alpha-x)) if (x < (one-alpha)) then kbarqqx = kbarqqx - CF * two/(one-x) * log((two-x)/(one-x)) end if end function kbarqq_al @ %def kbarqq_al <>= public :: kbargg_al <>= module function kbargg_al (x,alpha,eps,nf) result (kbarggx) real(default), intent(in) :: x, alpha, eps, nf real(default) :: kbarggx end function kbargg_al <>= module function kbargg_al (x,alpha,eps,nf) result (kbarggx) real(default), intent(in) :: x, alpha, eps, nf real(default) :: kbarggx kbarggx = pgg_reg(x) * log(alpha*(one-x)/x) & + CA * log_plus_distr(x,eps) & - (gamma_g(nf) + k_g_al(alpha,nf) - CA * & five/6.0_default * pi**2 - CA * (log(alpha))**2) * & delta(x,eps) + & CA * two/(one -x)*log(alpha*(two-x)/(one+alpha-x)) if (x < (one-alpha)) then kbarggx = kbarggx - CA * two/(one-x) * log((two-x)/(one-x)) end if end function kbargg_al @ %def kbargg_al @ The $\tilde{K}$ flavor kernels in the presence of a phase-space slicing parameter, are: \begin{equation} \tilde{K}^{ab} (x,\alpha) = P^{qq, \text{reg}} (x) \log\frac{1-x}{\alpha} + .......... \end{equation} <>= public :: ktildeqq_al <>= module function ktildeqq_al (x,alpha,eps) result (ktildeqqx) real(default), intent(in) :: x, eps, alpha real(default) :: ktildeqqx end function ktildeqq_al <>= module function ktildeqq_al (x,alpha,eps) result (ktildeqqx) real(default), intent(in) :: x, eps, alpha real(default) :: ktildeqqx ktildeqqx = pqq_reg(x) * log((one-x)/alpha) + CF*( & - log2_plus_distr_al(x,alpha,eps) - Pi**2/three * delta(x,eps) & + (one+x**2)/(one-x) * log(min(one,(alpha/(one-x)))) & + two/(one-x) * log((one+alpha-x)/alpha)) if (x > (one-alpha)) then ktildeqqx = ktildeqqx - CF*two/(one-x)*log(two-x) end if end function ktildeqq_al @ %def ktildeqq_al @ This is a logarithmic $+$-distribution, $\left( \frac{\log((1-x)/x)}{1-x} \right)_+$. For the sampling, we need the integral over this function over the incomplete sampling interval $[0,1-\epsilon]$, which is $\log^2(x) + 2 Li_2(x) - \frac{\pi^2}{3}$. As this function is negative definite for $\epsilon > 0.1816$, we take a hard upper limit for that sampling parameter, irrespective of the fact what the user chooses. <>= public :: log_plus_distr <>= module function log_plus_distr (x,eps) result (lpd) real(default), intent(in) :: x, eps real(default) :: lpd, eps2 end function log_plus_distr <>= module function log_plus_distr (x,eps) result (lpd) real(default), intent(in) :: x, eps real(default) :: lpd, eps2 eps2 = min (eps, 0.1816_default) if (x > (1.0_default - eps2)) then lpd = ((log(eps2))**2 + two*Li2(eps2) - pi**2/three)/eps2 else lpd = two*log((one-x)/x)/(one-x) end if end function log_plus_distr @ %def log_plus_distr @ Logarithmic $+$-distribution, $2 \left( \frac{\log(1/(1-x))}{1-x} \right)_+$. <>= public :: log2_plus_distr <>= module function log2_plus_distr (x,eps) result (lpd) real(default), intent(in) :: x, eps real(default) :: lpd end function log2_plus_distr <>= module function log2_plus_distr (x,eps) result (lpd) real(default), intent(in) :: x, eps real(default) :: lpd if (x > (1.0_default - eps)) then lpd = - (log(eps))**2/eps else lpd = two*log(one/(one-x))/(one-x) end if end function log2_plus_distr @ %def log2_plus_distr @ Logarithmic $+$-distribution with phase-space slicing parameter, $2 \left( \frac{\log(1/(1-x))}{1-x} \right)_{1-\alpha}$. <>= public :: log2_plus_distr_al <>= module function log2_plus_distr_al (x,alpha,eps) result (lpd_al) real(default), intent(in) :: x, eps, alpha real(default) :: lpd_al end function log2_plus_distr_al <>= module function log2_plus_distr_al (x,alpha,eps) result (lpd_al) real(default), intent(in) :: x, eps, alpha real(default) :: lpd_al if ((one - alpha) >= (one - eps)) then lpd_al = zero call msg_fatal ('alpha and epsilon chosen wrongly') elseif (x < (one - alpha)) then lpd_al = 0 elseif (x > (1.0_default - eps)) then lpd_al = - ((log(eps))**2 - (log(alpha))**2)/eps else lpd_al = two*log(one/(one-x))/(one-x) end if end function log2_plus_distr_al @ %def log2_plus_distr_al @ \subsection{Splitting Functions} @ Analogue to the regularized distributions of the last subsection, we give here the unregularized splitting functions, relevant for the parton shower algorithm. We can use this unregularized version since there will be a cut-off $\epsilon$ that ensures that $\{z,1-z\}>\epsilon(t)$. This cut-off seperates resolvable from unresolvable emissions. [[p_xxx]] are the kernels that are summed over helicity: <>= public :: p_qqg public :: p_gqq public :: p_ggg @ $q\to q g$ <>= elemental module function p_qqg (z) result (P) real(default), intent(in) :: z real(default) :: P end function p_qqg <>= elemental module function p_qqg (z) result (P) real(default), intent(in) :: z real(default) :: P P = CF * (one + z**2) / (one - z) end function p_qqg @ $g\to q \bar{q}$ <>= elemental module function p_gqq (z) result (P) real(default), intent(in) :: z real(default) :: P end function p_gqq <>= elemental module function p_gqq (z) result (P) real(default), intent(in) :: z real(default) :: P P = TR * (z**2 + (one - z)**2) end function p_gqq @ $g\to g g$ <>= elemental module function p_ggg (z) result (P) real(default), intent(in) :: z real(default) :: P end function p_ggg <>= elemental module function p_ggg (z) result (P) real(default), intent(in) :: z real(default) :: P P = NC * ((one - z) / z + z / (one - z) + z * (one - z)) end function p_ggg @ %def p_qqg p_gqq p_ggg @ Analytically integrated splitting kernels: <>= public :: integral_over_p_qqg public :: integral_over_p_gqq public :: integral_over_p_ggg <>= pure module function integral_over_p_qqg (zmin, zmax) result (integral) real(default), intent(in) :: zmin, zmax real(default) :: integral end function integral_over_p_qqg pure module function integral_over_p_gqq (zmin, zmax) result (integral) real(default), intent(in) :: zmin, zmax real(default) :: integral end function integral_over_p_gqq pure module function integral_over_p_ggg (zmin, zmax) result (integral) real(default), intent(in) :: zmin, zmax real(default) :: integral end function integral_over_p_ggg <>= pure module function integral_over_p_qqg (zmin, zmax) result (integral) real(default), intent(in) :: zmin, zmax real(default) :: integral integral = (two / three) * (- zmax**2 + zmin**2 - & two * (zmax - zmin) + four * log((one - zmin) / (one - zmax))) end function integral_over_p_qqg pure module function integral_over_p_gqq (zmin, zmax) result (integral) real(default), intent(in) :: zmin, zmax real(default) :: integral integral = 0.5_default * ((two / three) * & (zmax**3 - zmin**3) - (zmax**2 - zmin**2) + (zmax - zmin)) end function integral_over_p_gqq pure module function integral_over_p_ggg (zmin, zmax) result (integral) real(default), intent(in) :: zmin, zmax real(default) :: integral integral = three * ((log(zmax) - two * zmax - & log(one - zmax) + zmax**2 / two - zmax**3 / three) - & (log(zmin) - zmin - zmin - log(one - zmin) + zmin**2 & / two - zmin**3 / three) ) end function integral_over_p_ggg @ %def integral_over_p_gqq integral_over_p_ggg integral_over_p_qqg @ We can also use (massless) helicity dependent splitting functions: <>= public :: p_qqg_pol @ $q_a\to q_b g_c$, the helicity of the quark is not changed by gluon emission and the gluon is preferably polarized in the branching plane ($l_c=1$): <>= elemental module function p_qqg_pol (z, l_a, l_b, l_c) result (P) real(default), intent(in) :: z integer, intent(in) :: l_a, l_b, l_c real(default) :: P end function p_qqg_pol <>= elemental module function p_qqg_pol (z, l_a, l_b, l_c) result (P) real(default), intent(in) :: z integer, intent(in) :: l_a, l_b, l_c real(default) :: P if (l_a /= l_b) then P = zero return end if if (l_c == -1) then P = one - z else P = (one + z)**2 / (one - z) end if P = P * CF end function p_qqg_pol @ \subsubsection{Mellin transforms of splitting functions} As Mellin transforms necessarily live in the complex plane, all functions are defined as complex functions: @ Splitting function $P_{qq}(N)$: <>= public :: pqqm <>= module function pqqm (n, c_f) result (pqq_m) integer, intent(in) :: n real(default), intent(in) :: c_f complex(default) :: pqq_m end function pqqm <>= module function pqqm (n, c_f) result (pqq_m) integer, intent(in) :: n real(default), intent(in) :: c_f complex(default) :: pqq_m pqq_m = three - four * (eulerc + & psic(cmplx(N+1,zero,kind=default))) + two/N/(N+1) end function pqqm @ %def pqqm @ \subsection{Top width} In order to produce sensible results, the widths have to be recomputed for each parameter and order. We start with the LO-expression for the top width given by the decay $t\,\to\,W^+,b$, cf. [[doi:10.1016/0550-3213(91)90530-B]]:\\ The analytic formula given there is \begin{equation*} \Gamma = \frac{G_F m_t^2}{16\sqrt{2}\pi} \left[\mathcal{F}_0(\varepsilon, \xi^{-1/2}) - \frac{2\alpha_s}{3\pi} \mathcal{F}_1 (\varepsilon, \xi^{-1/2})\right], \end{equation*} with \begin{align*} \mathcal{F}_0 &= \frac{\sqrt{\lambda}}{2} f_0, \\ f_0 &= 4\left[(1-\varepsilon^2)^2 + w^2(1+\varepsilon^2) - 2w^4\right], \\ \lambda = 1 + w^4 + \varepsilon^4 - 2(w^2 + \varepsilon^2 + w^2\varepsilon^2). \end{align*} Defining \begin{equation*} u_q = \frac{1 + \varepsilon^2 - w^2 - \lambda^{1/2}}{1 + \varepsilon^2 - w^2 + \lambda^{1/2}} \end{equation*} and \begin{equation*} u_w = \frac{1 - \varepsilon^2 + w^2 - \lambda^{1/2}}{1 - \varepsilon^2 + w^2 + \lambda^{1/2}} \end{equation*} the factor $\mathcal{F}_1$ can be expressed as \begin{align*} \mathcal{F}_1 = \frac{1}{2}f_0(1+\varepsilon^2-w^2) & \left[\pi^2 + 2Li_2(u_w) - 2Li_2(1-u_w) - 4Li_2(u_q) \right. \\ & -4Li_2(u_q u_w) + \log\left(\frac{1-u_q}{w^2}\right)\log(1-u_q) - \log^2(1-u_q u_w) \\ & \left.+\frac{1}{4}\log^2\left(\frac{w^2}{u_w}\right) - \log(u_w) \log\left[\frac{(1-u_q u_w)^2}{1-u_q}\right] -2\log(u_q)\log\left[(1-u_q)(1-u_q u_w)\right]\right] \\ & -\sqrt{\lambda}f_0(2\log(w) + 3\log(\varepsilon) - 2\log{\lambda}) \\ & +4(1-\varepsilon^2)\left[(1-\varepsilon^2)^2 + w^2(1+\varepsilon^2) - 4w^4\right]\log(u_w) \\ & \left[(3 - \varepsilon^2 + 11\varepsilon^4 - \varepsilon^6) + w^2(6 - 12\varepsilon^2 +2\varepsilon^4) - w^4(21 + 5\varepsilon^2) + 12w^6\right] \log(u_q) \\ & 6\sqrt{\lambda} (1-\varepsilon^2) (1 + \varepsilon^2 - w^2) \log(\varepsilon) + \sqrt{\lambda}\left[-5 + 22\varepsilon^2 - 5\varepsilon^4 - 9w^2(1+\varepsilon^2) + 6w^4\right]. \end{align*} @ <>= public :: top_width_sm_lo <>= elemental module function top_width_sm_lo (alpha, sinthw, vtb, mtop, mw, mb) & result (gamma) real(default) :: gamma real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, mb end function top_width_sm_lo <>= elemental module function top_width_sm_lo (alpha, sinthw, vtb, mtop, mw, mb) & result (gamma) real(default) :: gamma real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, mb real(default) :: kappa kappa = sqrt ((mtop**2 - (mw + mb)**2) * (mtop**2 - (mw - mb)**2)) gamma = alpha / four * mtop / (two * sinthw**2) * & vtb**2 * kappa / mtop**2 * & ((mtop**2 + mb**2) / (two * mtop**2) + & (mtop**2 - mb**2)**2 / (two * mtop**2 * mw**2) - & mw**2 / mtop**2) end function top_width_sm_lo @ %def top_width_sm_lo @ <>= public :: g_mu_from_alpha <>= elemental module function g_mu_from_alpha (alpha, mw, sinthw) result (g_mu) real(default) :: g_mu real(default), intent(in) :: alpha, mw, sinthw end function g_mu_from_alpha <>= elemental module function g_mu_from_alpha (alpha, mw, sinthw) result (g_mu) real(default) :: g_mu real(default), intent(in) :: alpha, mw, sinthw g_mu = pi * alpha / sqrt(two) / mw**2 / sinthw**2 end function g_mu_from_alpha @ %def g_mu_from_alpha @ <>= public :: alpha_from_g_mu <>= elemental module function alpha_from_g_mu (g_mu, mw, sinthw) result (alpha) real(default) :: alpha real(default), intent(in) :: g_mu, mw, sinthw end function alpha_from_g_mu <>= elemental module function alpha_from_g_mu (g_mu, mw, sinthw) result (alpha) real(default) :: alpha real(default), intent(in) :: g_mu, mw, sinthw alpha = g_mu * sqrt(two) / pi * mw**2 * sinthw**2 end function alpha_from_g_mu @ %def alpha_from_g_mu @ Cf. (3.3)-(3.7) in [[1207.5018]]. <>= public :: top_width_sm_qcd_nlo_massless_b <>= elemental module function top_width_sm_qcd_nlo_massless_b & (alpha, sinthw, vtb, mtop, mw, alphas) result (gamma) real(default) :: gamma real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, alphas end function top_width_sm_qcd_nlo_massless_b <>= elemental module function top_width_sm_qcd_nlo_massless_b & (alpha, sinthw, vtb, mtop, mw, alphas) result (gamma) real(default) :: gamma real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, alphas real(default) :: prefac, g_mu, w2 g_mu = g_mu_from_alpha (alpha, mw, sinthw) prefac = g_mu * mtop**3 * vtb**2 / (16 * sqrt(two) * pi) w2 = mw**2 / mtop**2 gamma = prefac * (f0 (w2) - (two * alphas) / (3 * Pi) * f1 (w2)) end function top_width_sm_qcd_nlo_massless_b @ %def top_width_sm_qcd_nlo_massless_b @ <>= public :: f0 <>= elemental module function f0 (w2) result (f) real(default) :: f real(default), intent(in) :: w2 end function f0 <>= elemental module function f0 (w2) result (f) real(default) :: f real(default), intent(in) :: w2 f = two * (one - w2)**2 * (1 + 2 * w2) end function f0 @ %def f0 @ <>= public :: f1 <>= elemental module function f1 (w2) result (f) real(default) :: f real(default), intent(in) :: w2 end function f1 <>= elemental module function f1 (w2) result (f) real(default) :: f real(default), intent(in) :: w2 f = f0 (w2) * (pi**2 + two * Li2 (w2) - two * Li2 (one - w2)) & + four * w2 * (one - w2 - two * w2**2) * log (w2) & + two * (one - w2)**2 * (five + four * w2) * log (one - w2) & - (one - w2) * (five + 9 * w2 - 6 * w2**2) end function f1 @ %def f1 @ Basically, the same as above but with $m_b$ dependence, cf. Jezabek / Kuehn 1989. <>= public :: top_width_sm_qcd_nlo_jk <>= elemental module function top_width_sm_qcd_nlo_jk & (alpha, sinthw, vtb, mtop, mw, mb, alphas) result (gamma) real(default) :: gamma real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, mb, alphas end function top_width_sm_qcd_nlo_jk <>= elemental module function top_width_sm_qcd_nlo_jk & (alpha, sinthw, vtb, mtop, mw, mb, alphas) result (gamma) real(default) :: gamma real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, mb, alphas real(default) :: prefac, g_mu, eps2, i_xi g_mu = g_mu_from_alpha (alpha, mw, sinthw) prefac = g_mu * mtop**3 * vtb**2 / (16 * sqrt(two) * pi) eps2 = (mb / mtop)**2 i_xi = (mw / mtop)**2 gamma = prefac * (ff0 (eps2, i_xi) - & (two * alphas) / (3 * Pi) * ff1 (eps2, i_xi)) end function top_width_sm_qcd_nlo_jk @ %def top_width_sm_qcd_nlo_jk @ Same as above, $m_b > 0$, with the slightly different implementation (2.6) of arXiv:1204.1513v1 by Campbell and Ellis. <>= public :: top_width_sm_qcd_nlo_ce <>= elemental module function top_width_sm_qcd_nlo_ce & (alpha, sinthw, vtb, mtop, mw, mb, alpha_s) result (gamma) real(default) :: gamma real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, mb, alpha_s end function top_width_sm_qcd_nlo_ce <>= elemental module function top_width_sm_qcd_nlo_ce & (alpha, sinthw, vtb, mtop, mw, mb, alpha_s) result (gamma) real(default) :: gamma real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, mb, alpha_s real(default) :: pm, pp, p0, p3 real(default) :: yw, yp real(default) :: W0, Wp, Wm, w2 real(default) :: beta2 real(default) :: f real(default) :: g_mu, gamma0 beta2 = (mb / mtop)**2 w2 = (mw / mtop)**2 p0 = (one - w2 + beta2) / two p3 = sqrt (lambda (one, w2, beta2)) / two pp = p0 + p3 pm = p0 - p3 W0 = (one + w2 - beta2) / two Wp = W0 + p3 Wm = W0 - p3 yp = log (pp / pm) / two yw = log (Wp / Wm) / two f = (one - beta2)**2 + w2 * (one + beta2) - two * w2**2 g_mu = g_mu_from_alpha (alpha, mw, sinthw) gamma0 = g_mu * mtop**3 * vtb**2 / (8 * pi * sqrt(two)) gamma = gamma0 * alpha_s / twopi * CF * & (8 * f * p0 * (Li2(one - pm) - Li2(one - pp) - two * Li2(one - pm / pp) & + yp * log((four * p3**2) / (pp**2 * Wp)) + yw * log (pp)) & + four * (one - beta2) * ((one - beta2)**2 + w2 * (one + beta2) - four * w2**2) * yw & + (3 - beta2 + 11 * beta2**2 - beta2**3 + w2 * (6 - 12 * beta2 + two * beta2**2) & - w2**2 * (21 + 5 * beta2) + 12 * w2**3) * yp & + 8 * f * p3 * log (sqrt(w2) / (four * p3**2)) & + 6 * (one - four * beta2 + 3 * beta2**2 + w2 * (3 + beta2) - four * w2**2) * p3 * log(sqrt(beta2)) & + (5 - 22 * beta2 + 5 * beta2**2 + 9 * w2 * (one + beta2) - 6 * w2**2) * p3) end function top_width_sm_qcd_nlo_ce @ %def top_width_sm_qcd_nlo_ce @ <>= public :: ff0 <>= elemental module function ff0 (eps2, w2) result (f) real(default) :: f real(default), intent(in) :: eps2, w2 end function ff0 <>= elemental module function ff0 (eps2, w2) result (f) real(default) :: f real(default), intent(in) :: eps2, w2 f = one / two * sqrt(ff_lambda (eps2, w2)) * ff_f0 (eps2, w2) end function ff0 @ %def ff0 @ <>= public :: ff_f0 <>= elemental module function ff_f0 (eps2, w2) result (f) real(default) :: f real(default), intent(in) :: eps2, w2 end function ff_f0 <>= elemental module function ff_f0 (eps2, w2) result (f) real(default) :: f real(default), intent(in) :: eps2, w2 f = four * ((1 - eps2)**2 + w2 * (1 + eps2) - 2 * w2**2) end function ff_f0 @ %def ff_f0 @ <>= public :: ff_lambda <>= elemental module function ff_lambda (eps2, w2) result (l) real(default) :: l real(default), intent(in) :: eps2, w2 end function ff_lambda <>= elemental module function ff_lambda (eps2, w2) result (l) real(default) :: l real(default), intent(in) :: eps2, w2 l = one + w2**2 + eps2**2 - two * (w2 + eps2 + w2 * eps2) end function ff_lambda @ %def ff_lambda @ <>= public :: ff1 <>= elemental module function ff1 (eps2, w2) result (f) real(default) :: f real(default), intent(in) :: eps2, w2 end function ff1 <>= elemental module function ff1 (eps2, w2) result (f) real(default) :: f real(default), intent(in) :: eps2, w2 real(default) :: uq, uw, sq_lam, fff sq_lam = sqrt (ff_lambda (eps2, w2)) fff = ff_f0 (eps2, w2) uw = (one - eps2 + w2 - sq_lam) / & (one - eps2 + w2 + sq_lam) uq = (one + eps2 - w2 - sq_lam) / & (one + eps2 - w2 + sq_lam) f = one / two * fff * (one + eps2 - w2) * & (pi**2 + two * Li2 (uw) - two * Li2 (one - uw) - four * Li2 (uq) & - four * Li2 (uq * uw) + log ((one - uq) / w2) * log (one - uq) & - log (one - uq * uw)**2 + one / four * log (w2 / uw)**2 & - log (uw) * log ((one - uq * uw)**2 / (one - uq)) & - two * log (uq) * log ((one - uq) * (one - uq * uw))) & - sq_lam * fff * (two * log (sqrt (w2)) & + three * log (sqrt (eps2)) - two * log (sq_lam**2)) & + four * (one - eps2) * ((one - eps2)**2 + w2 * (one + eps2) & - four * w2**2) * log (uw) & + (three - eps2 + 11 * eps2**2 - eps2**3 + w2 * & (6 - 12 * eps2 + 2 * eps2**2) - w2**2 * (21 + five * eps2) & + 12 * w2**3) * log (uq) & + 6 * sq_lam * (one - eps2) * & (one + eps2 - w2) * log (sqrt (eps2)) & + sq_lam * (- five + 22 * eps2 - five * eps2**2 - 9 * w2 * & (one + eps2) + 6 * w2**2) end function ff1 @ %def ff1 @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sm_physics_ut.f90]]>>= <> module sm_physics_ut use unit_tests use sm_physics_uti <> <> contains <> end module sm_physics_ut @ %def sm_physics_ut @ <<[[sm_physics_uti.f90]]>>= <> module sm_physics_uti <> use numeric_utils use format_defs, only: FMT_15 use constants use sm_physics <> <> contains <> end module sm_physics_uti @ %def sm_physics_ut @ API: driver for the unit tests below. <>= public :: sm_physics_test <>= subroutine sm_physics_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sm_physics_test @ %def sm_physics_test @ \subsubsection{Splitting functions} <>= call test (sm_physics_1, "sm_physics_1", & "Splitting functions", & u, results) <>= public :: sm_physics_1 <>= subroutine sm_physics_1 (u) integer, intent(in) :: u real(default) :: z = 0.75_default write (u, "(A)") "* Test output: sm_physics_1" write (u, "(A)") "* Purpose: check analytic properties" write (u, "(A)") write (u, "(A)") "* Splitting functions:" write (u, "(A)") call assert (u, vanishes (p_qqg_pol (z, +1, -1, +1)), "+-+") call assert (u, vanishes (p_qqg_pol (z, +1, -1, -1)), "+--") call assert (u, vanishes (p_qqg_pol (z, -1, +1, +1)), "-++") call assert (u, vanishes (p_qqg_pol (z, -1, +1, -1)), "-+-") !call assert (u, nearly_equal ( & !p_qqg_pol (z, +1, +1, -1) + p_qqg_pol (z, +1, +1, +1), & !p_qqg (z)), "pol sum") write (u, "(A)") write (u, "(A)") "* Test output end: sm_physics_1" end subroutine sm_physics_1 @ %def sm_physics_1 @ \subsubsection{Top width} <>= call test(sm_physics_2, "sm_physics_2", & "Top width", u, results) <>= public :: sm_physics_2 <>= subroutine sm_physics_2 (u) integer, intent(in) :: u real(default) :: mtop, mw, mz, mb, g_mu, sinthw, alpha, vtb, gamma0 real(default) :: w2, alphas, alphas_mz, gamma1 write (u, "(A)") "* Test output: sm_physics_2" write (u, "(A)") "* Purpose: Check different top width computations" write (u, "(A)") write (u, "(A)") "* Values from [[1207.5018]] (massless b)" mtop = 172.0 mw = 80.399 mz = 91.1876 mb = zero mb = 0.00001 g_mu = 1.16637E-5 sinthw = sqrt(one - mw**2 / mz**2) alpha = alpha_from_g_mu (g_mu, mw, sinthw) vtb = one w2 = mw**2 / mtop**2 write (u, "(A)") "* Check Li2 implementation" call assert_equal (u, Li2(w2), 0.2317566263959552_default, & "Li2(w2)", rel_smallness=1.0E-6_default) call assert_equal (u, Li2(one - w2), 1.038200378935867_default, & "Li2(one - w2)", rel_smallness=1.0E-6_default) write (u, "(A)") "* Check LO Width" gamma0 = top_width_sm_lo (alpha, sinthw, vtb, mtop, mw, mb) call assert_equal (u, gamma0, 1.4655_default, & "top_width_sm_lo", rel_smallness=1.0E-5_default) alphas = zero gamma0 = top_width_sm_qcd_nlo_massless_b & (alpha, sinthw, vtb, mtop, mw, alphas) call assert_equal (u, gamma0, 1.4655_default, & "top_width_sm_qcd_nlo_massless_b", rel_smallness=1.0E-5_default) gamma0 = top_width_sm_qcd_nlo_jk & (alpha, sinthw, vtb, mtop, mw, mb, alphas) call assert_equal (u, gamma0, 1.4655_default, & "top_width_sm_qcd_nlo", rel_smallness=1.0E-5_default) write (u, "(A)") "* Check NLO Width" alphas_mz = 0.1202 ! MSTW2008 NLO fit alphas = running_as (mtop, alphas_mz, mz, 1, 5.0_default) gamma1 = top_width_sm_qcd_nlo_massless_b & (alpha, sinthw, vtb, mtop, mw, alphas) call assert_equal (u, gamma1, 1.3376_default, rel_smallness=1.0E-4_default) gamma1 = top_width_sm_qcd_nlo_jk & (alpha, sinthw, vtb, mtop, mw, mb, alphas) ! It would be nice to get one more significant digit but the ! expression is numerically rather unstable for mb -> 0 call assert_equal (u, gamma1, 1.3376_default, rel_smallness=1.0E-3_default) write (u, "(A)") "* Values from threshold validation (massive b)" alpha = one / 125.924 ! ee = 0.315901 ! cw = 0.881903 ! v = 240.024 mtop = 172.0 ! This is the value for M1S !!! mb = 4.2 sinthw = 0.47143 mz = 91.188 mw = 80.419 call assert_equal (u, sqrt(one - mw**2 / mz**2), sinthw, & "sinthw", rel_smallness=1.0E-6_default) write (u, "(A)") "* Check LO Width" gamma0 = top_width_sm_lo (alpha, sinthw, vtb, mtop, mw, mb) call assert_equal (u, gamma0, 1.5386446_default, & "gamma0", rel_smallness=1.0E-7_default) alphas = zero gamma0 = top_width_sm_qcd_nlo_jk & (alpha, sinthw, vtb, mtop, mw, mb, alphas) call assert_equal (u, gamma0, 1.5386446_default, & "gamma0", rel_smallness=1.0E-7_default) write (u, "(A)") "* Check NLO Width" alphas_mz = 0.118 !(Z pole, NLL running to mu_h) alphas = running_as (mtop, alphas_mz, mz, 1, 5.0_default) write (u, "(A," // FMT_15 // ")") "* alphas = ", alphas gamma1 = top_width_sm_qcd_nlo_jk & (alpha, sinthw, vtb, mtop, mw, mb, alphas) write (u, "(A," // FMT_15 // ")") "* Gamma1 = ", gamma1 mb = zero gamma1 = top_width_sm_qcd_nlo_massless_b & (alpha, sinthw, vtb, mtop, mw, alphas) alphas = running_as (mtop, alphas_mz, mz, 1, 5.0_default) write (u, "(A," // FMT_15 // ")") "* Gamma1(mb=0) = ", gamma1 write (u, "(A)") write (u, "(A)") "* Test output end: sm_physics_2" end subroutine sm_physics_2 @ %def sm_physics_2 @ \subsubsection{Special functions} <>= call test (sm_physics_3, "sm_physics_3", & "Special functions", & u, results) <>= public :: sm_physics_3 <>= subroutine sm_physics_3 (u) integer, intent(in) :: u complex(default) :: z1 = (0.75_default, 1.25_default) complex(default) :: z2 = (1.33_default, 11.25_default) complex(default) :: psiz + real(default) :: x1 = 0.045847700_default + real(default) :: psir write (u, "(A)") "* Test output: sm_physics_3" write (u, "(A)") "* Purpose: check special functions" write (u, "(A)") write (u, "(A)") "* Complex digamma function:" write (u, "(A)") psiz = psic (z1) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z1 = ", & real(z1), aimag(z1) write (u, "(1x,A,'(',F7.5,',',F7.5,')')") " psi(z1) = ", & real(psiz), aimag(psiz) psiz = psic (z2) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z2 = ", & real(z2), aimag(z2) write (u, "(1x,A,'(',F7.5,',',F7.5,')')") " psi(z2) = ", & real(psiz), aimag(psiz) write (u, "(A)") write (u, "(A)") "* Complex polygamma function:" write (u, "(A)") psiz = psim (z1,1) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z1 = ", & real(z1), aimag(z1) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z1,1) = ", & real(psiz), aimag(psiz) psiz = psim (z2,1) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z2 = ", & real(z2), aimag(z2) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z2,1) = ", & real(psiz), aimag(psiz) write (u, "(A)") psiz = psim (z1,2) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z1 = ", & real(z1), aimag(z1) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z1,2) = ", & real(psiz), aimag(psiz) psiz = psim (z2,2) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z2 = ", & real(z2), aimag(z2) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z2,2) = ", & real(psiz), aimag(psiz) write (u, "(A)") psiz = psim (z1,3) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z1 = ", & real(z1), aimag(z1) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z1,3) = ", & real(psiz), aimag(psiz) psiz = psim (z2,3) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z2 = ", & real(z2), aimag(z2) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z2,3) = ", & real(psiz), aimag(psiz) write (u, "(A)") psiz = psim (z1,4) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z1 = ", & real(z1), aimag(z1) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z1,4) = ", & real(psiz), aimag(psiz) psiz = psim (z2,4) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z2 = ", & real(z2), aimag(z2) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z2,4) = ", & real(psiz), aimag(psiz) write (u, "(A)") psiz = psim (z1,5) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z1 = ", & real(z1), aimag(z1) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z1,5) = ", & real(psiz), aimag(psiz) psiz = psim (z2,5) write (u, "(1x,A,'(',F5.2,',',F5.2,')')") " z2 = ", & real(z2), aimag(z2) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " psi(z2,5) = ", & real(psiz), aimag(psiz) write (u, "(A)") + write (u, "(A)") "* Real polygamma function:" + write (u, "(A)") + + psir = psimr (x1,1) + write (u, "(1x,A,'(',F8.5,')')") " x1 = ", x1 + write (u, "(1x,A,'(',F8.4,')')") " psir = ", psir + + write (u, "(A)") write (u, "(A)") "* Generalized Nielsen polylogarithm:" write (u, "(A)") write (u, "(1x,A,F8.5)") " S(1,1,0) = ", & nielsen(1,1,0._default) write (u, "(1x,A,F8.5)") " S(1,1,-1) = ", & nielsen(1,1,-1._default) write (u, "(1x,A,F8.5)") " S(1,2,-1) = ", & nielsen(1,2,-1._default) write (u, "(1x,A,F8.5)") " S(2,1,-1) = ", & nielsen(2,1,-1._default) write (u, "(1x,A,F8.5)") " S(1,3,-1) = ", & nielsen(1,3,-1._default) write (u, "(1x,A,F8.5)") " S(2,2,-1) = ", & nielsen(2,2,-1._default) write (u, "(1x,A,F8.5)") " S(3,1,-1) = ", & nielsen(3,1,-1._default) write (u, "(1x,A,F8.5)") " S(1,4,-1) = ", & nielsen(1,4,-1._default) write (u, "(1x,A,F8.5)") " S(2,3,-1) = ", & nielsen(2,3,-1._default) write (u, "(1x,A,F8.5)") " S(3,2,-1) = ", & nielsen(3,2,-1._default) write (u, "(1x,A,F8.5)") " S(4,1,-1) = ", & nielsen(4,1,-1._default) write (u, "(1x,A,F8.5)") " S(1,1,0.2) = ", & nielsen(1,1,0.2_default) write (u, "(1x,A,F8.5)") " S(1,2,0.2) = ", & nielsen(1,2,0.2_default) write (u, "(1x,A,F8.5)") " S(2,1,0.2) = ", & nielsen(2,1,0.2_default) write (u, "(1x,A,F8.5)") " S(1,3,0.2) = ", & nielsen(1,3,0.2_default) write (u, "(1x,A,F8.5)") " S(2,2,0.2) = ", & nielsen(2,2,0.2_default) write (u, "(1x,A,F8.5)") " S(3,1,0.2) = ", & nielsen(3,1,0.2_default) write (u, "(1x,A,F8.5)") " S(1,4,0.2) = ", & nielsen(1,4,0.2_default) write (u, "(1x,A,F8.5)") " S(2,3,0.2) = ", & nielsen(2,3,0.2_default) write (u, "(1x,A,F8.5)") " S(3,2,0.2) = ", & nielsen(3,2,0.2_default) write (u, "(1x,A,F8.5)") " S(4,1,0.2) = ", & nielsen(4,1,0.2_default) write (u, "(1x,A,F8.5)") " S(1,1,1) = ", & nielsen(1,1,1._default) write (u, "(1x,A,F8.5)") " S(1,2,1) = ", & nielsen(1,2,1._default) write (u, "(1x,A,F8.5)") " S(2,1,1) = ", & nielsen(2,1,1._default) write (u, "(1x,A,F8.5)") " S(1,3,1) = ", & nielsen(1,3,1._default) write (u, "(1x,A,F8.5)") " S(2,2,1) = ", & nielsen(2,2,1._default) write (u, "(1x,A,F8.5)") " S(3,1,1) = ", & nielsen(3,1,1._default) write (u, "(1x,A,F8.5)") " S(1,4,1) = ", & nielsen(1,4,1._default) write (u, "(1x,A,F8.5)") " S(2,3,1) = ", & nielsen(2,3,1._default) write (u, "(1x,A,F8.5)") " S(3,2,1) = ", & nielsen(3,2,1._default) write (u, "(1x,A,F8.5)") " S(4,1,1) = ", & nielsen(4,1,1._default) write (u, "(1x,A,F8.5)") " S(1,1,0.75) = ", & nielsen(1,1,0.75_default) write (u, "(1x,A,F8.5)") " S(1,3,0.75) = ", & nielsen(1,3,0.75_default) write (u, "(1x,A,F8.5)") " S(1,4,0.75) = ", & nielsen(1,4,0.75_default) write (u, "(1x,A,F8.5)") " S(2,2,0.75) = ", & nielsen(2,2,0.75_default) write (u, "(1x,A,'(',F8.5,',',F8.5,')')") " S(1,1,2) = ", & real(cnielsen(1,1,3._default)), & aimag(cnielsen(1,1,3._default)) write (u, "(A)") write (u, "(A)") "* Dilog, trilog, polylog:" write (u, "(A)") write (u, "(1x,A,F8.5)") " Li2(0.66) = ", & dilog(0.66_default) write (u, "(1x,A,F8.5)") " Li3(0.66) = ", & trilog(0.66_default) write (u, "(1x,A,F8.5)") " Poly(4,0.66) = ", & polylog(4,0.66_default) write (u, "(A)") write (u, "(A)") "* Test output end: sm_physics_3" end subroutine sm_physics_3 @ %def sm_physics_3 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{QCD Coupling} We provide various distinct implementations of the QCD coupling. In this module, we define an abstract data type and three implementations: fixed, running with $\alpha_s(M_Z)$ as input, and running with $\Lambda_{\text{QCD}}$ as input. We use the functions defined above in the module [[sm_physics]] but provide a common interface. Later modules may define additional implementations. <<[[sm_qcd.f90]]>>= <> module sm_qcd <> use physics_defs <> <> <> <> interface <> end interface end module sm_qcd @ %def sm_qcd @ <<[[sm_qcd_sub.f90]]>>= <> submodule (sm_qcd) sm_qcd_s use io_units use format_defs, only: FMT_12 use numeric_utils use diagnostics use md5 use sm_physics implicit none contains <> end submodule sm_qcd_s @ %def sm_qcd_s @ \subsection{Coupling: Abstract Data Type} This is the abstract version of the QCD coupling implementation. <>= public :: alpha_qcd_t <>= type, abstract :: alpha_qcd_t contains <> end type alpha_qcd_t @ %def alpha_qcd_t @ There must be an output routine. <>= procedure (alpha_qcd_write), deferred :: write <>= abstract interface subroutine alpha_qcd_write (object, unit) import class(alpha_qcd_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine alpha_qcd_write end interface @ %def alpha_qcd_write @ This method computes the running coupling, given a certain scale. All parameters (reference value, order of the approximation, etc.) must be set before calling this. <>= procedure (alpha_qcd_get), deferred :: get <>= abstract interface function alpha_qcd_get (alpha_qcd, scale) result (alpha) import class(alpha_qcd_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha end function alpha_qcd_get end interface @ %def alpha_qcd_get @ \subsection{Fixed Coupling} In this version, the $\alpha_s$ value is fixed, the [[scale]] argument of the [[get]] method is ignored. There is only one parameter, the value. By default, this is the value at $M_Z$. <>= public :: alpha_qcd_fixed_t <>= type, extends (alpha_qcd_t) :: alpha_qcd_fixed_t real(default) :: val = ALPHA_QCD_MZ_REF contains <> end type alpha_qcd_fixed_t @ %def alpha_qcd_fixed_t @ Output. <>= procedure :: write => alpha_qcd_fixed_write <>= module subroutine alpha_qcd_fixed_write (object, unit) class(alpha_qcd_fixed_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine alpha_qcd_fixed_write <>= module subroutine alpha_qcd_fixed_write (object, unit) class(alpha_qcd_fixed_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(3x,A)") "QCD parameters (fixed coupling):" write (u, "(5x,A," // FMT_12 // ")") "alpha = ", object%val end subroutine alpha_qcd_fixed_write @ %def alpha_qcd_fixed_write @ Calculation: the scale is ignored in this case. <>= procedure :: get => alpha_qcd_fixed_get <>= module function alpha_qcd_fixed_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_fixed_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha end function alpha_qcd_fixed_get <>= module function alpha_qcd_fixed_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_fixed_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha alpha = alpha_qcd%val end function alpha_qcd_fixed_get @ %def alpha_qcd_fixed_get @ \subsection{Running Coupling} In this version, the $\alpha_s$ value runs relative to the value at a given reference scale. There are two parameters: the value of this scale (default: $M_Z$), the value of $\alpha_s$ at this scale, and the number of effective flavors. Furthermore, we have the order of the approximation. <>= public :: alpha_qcd_from_scale_t <>= type, extends (alpha_qcd_t) :: alpha_qcd_from_scale_t real(default) :: mu_ref = MZ_REF real(default) :: ref = ALPHA_QCD_MZ_REF integer :: order = 0 integer :: nf = 5 contains <> end type alpha_qcd_from_scale_t @ %def alpha_qcd_from_scale_t @ Output. <>= procedure :: write => alpha_qcd_from_scale_write <>= module subroutine alpha_qcd_from_scale_write (object, unit) class(alpha_qcd_from_scale_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine alpha_qcd_from_scale_write <>= module subroutine alpha_qcd_from_scale_write (object, unit) class(alpha_qcd_from_scale_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(3x,A)") "QCD parameters (running coupling):" write (u, "(5x,A," // FMT_12 // ")") "Scale mu = ", object%mu_ref write (u, "(5x,A," // FMT_12 // ")") "alpha(mu) = ", object%ref write (u, "(5x,A,I0)") "LL order = ", object%order write (u, "(5x,A,I0)") "N(flv) = ", object%nf end subroutine alpha_qcd_from_scale_write @ %def alpha_qcd_from_scale_write @ Calculation: here, we call the function for running $\alpha_s$ that was defined in [[sm_physics]] above. The function does not take into account thresholds, so the number of flavors should be the correct one for the chosen scale. Normally, this should be the $Z$ boson mass. <>= procedure :: get => alpha_qcd_from_scale_get <>= module function alpha_qcd_from_scale_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_from_scale_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha end function alpha_qcd_from_scale_get <>= module function alpha_qcd_from_scale_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_from_scale_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha alpha = running_as (scale, alpha_qcd%ref, alpha_qcd%mu_ref, & alpha_qcd%order, real (alpha_qcd%nf, kind=default)) end function alpha_qcd_from_scale_get @ %def alpha_qcd_from_scale_get @ \subsection{Running Coupling, determined by $\Lambda_{\text{QCD}}$} In this version, the inputs are the value $\Lambda_{\text{QCD}}$ and the order of the approximation. <>= public :: alpha_qcd_from_lambda_t <>= type, extends (alpha_qcd_t) :: alpha_qcd_from_lambda_t real(default) :: lambda = LAMBDA_QCD_REF integer :: order = 0 integer :: nf = 5 contains <> end type alpha_qcd_from_lambda_t @ %def alpha_qcd_from_lambda_t @ Output. <>= procedure :: write => alpha_qcd_from_lambda_write <>= module subroutine alpha_qcd_from_lambda_write (object, unit) class(alpha_qcd_from_lambda_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine alpha_qcd_from_lambda_write <>= module subroutine alpha_qcd_from_lambda_write (object, unit) class(alpha_qcd_from_lambda_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(3x,A)") "QCD parameters (Lambda_QCD as input):" write (u, "(5x,A," // FMT_12 // ")") "Lambda_QCD = ", object%lambda write (u, "(5x,A,I0)") "LL order = ", object%order write (u, "(5x,A,I0)") "N(flv) = ", object%nf end subroutine alpha_qcd_from_lambda_write @ %def alpha_qcd_from_lambda_write @ Calculation: here, we call the second function for running $\alpha_s$ that was defined in [[sm_physics]] above. The $\Lambda$ value should be the one that is appropriate for the chosen number of effective flavors. Again, thresholds are not incorporated. <>= procedure :: get => alpha_qcd_from_lambda_get <>= module function alpha_qcd_from_lambda_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_from_lambda_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha end function alpha_qcd_from_lambda_get <>= module function alpha_qcd_from_lambda_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_from_lambda_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha alpha = running_as_lam (real (alpha_qcd%nf, kind=default), scale, & alpha_qcd%lambda, alpha_qcd%order) end function alpha_qcd_from_lambda_get @ %def alpha_qcd_from_lambda_get @ \subsection{QCD Wrapper type} We could get along with a polymorphic QCD type, but a monomorphic wrapper type with a polymorphic component is easier to handle and probably safer (w.r.t.\ compiler bugs). However, we keep the object transparent, so we can set the type-specific parameters directly (by a [[dispatch]] routine). <>= public :: qcd_t <>= type :: qcd_t class(alpha_qcd_t), allocatable :: alpha character(32) :: md5sum = "" integer :: n_f = -1 contains <> end type qcd_t @ %def qcd_t @ Output. We first print the polymorphic [[alpha]] which contains a headline, then any extra components. <>= procedure :: write => qcd_write <>= module subroutine qcd_write (qcd, unit, show_md5sum) class(qcd_t), intent(in) :: qcd integer, intent(in), optional :: unit logical, intent(in), optional :: show_md5sum end subroutine qcd_write <>= module subroutine qcd_write (qcd, unit, show_md5sum) class(qcd_t), intent(in) :: qcd integer, intent(in), optional :: unit logical, intent(in), optional :: show_md5sum logical :: show_md5 integer :: u u = given_output_unit (unit); if (u < 0) return show_md5 = .true.; if (present (show_md5sum)) show_md5 = show_md5sum if (allocated (qcd%alpha)) then call qcd%alpha%write (u) else write (u, "(3x,A)") "QCD parameters (coupling undefined)" end if if (show_md5 .and. qcd%md5sum /= "") & write (u, "(5x,A,A,A)") "md5sum = '", qcd%md5sum, "'" end subroutine qcd_write @ %def qcd_write @ Compute an MD5 sum for the [[alpha_s]] setup. This is done by writing them to a temporary file, using a standard format. <>= procedure :: compute_alphas_md5sum => qcd_compute_alphas_md5sum <>= module subroutine qcd_compute_alphas_md5sum (qcd) class(qcd_t), intent(inout) :: qcd integer :: unit end subroutine qcd_compute_alphas_md5sum <>= module subroutine qcd_compute_alphas_md5sum (qcd) class(qcd_t), intent(inout) :: qcd integer :: unit if (allocated (qcd%alpha)) then unit = free_unit () open (unit, status="scratch", action="readwrite") call qcd%alpha%write (unit) rewind (unit) qcd%md5sum = md5sum (unit) close (unit) end if end subroutine qcd_compute_alphas_md5sum @ %def qcd_compute_alphas_md5sum @ @ Retrieve the MD5 sum of the qcd setup. <>= procedure :: get_md5sum => qcd_get_md5sum <>= module function qcd_get_md5sum (qcd) result (md5sum) character(32) :: md5sum class(qcd_t), intent(inout) :: qcd end function qcd_get_md5sum <>= module function qcd_get_md5sum (qcd) result (md5sum) character(32) :: md5sum class(qcd_t), intent(inout) :: qcd md5sum = qcd%md5sum end function qcd_get_md5sum @ %def qcd_get_md5sum @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sm_qcd_ut.f90]]>>= <> module sm_qcd_ut use unit_tests use sm_qcd_uti <> <> contains <> end module sm_qcd_ut @ %def sm_qcd_ut @ <<[[sm_qcd_uti.f90]]>>= <> module sm_qcd_uti <> use physics_defs, only: MZ_REF use sm_qcd <> <> contains <> end module sm_qcd_uti @ %def sm_qcd_ut @ API: driver for the unit tests below. <>= public :: sm_qcd_test <>= subroutine sm_qcd_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sm_qcd_test @ %def sm_qcd_test @ \subsubsection{QCD Coupling} We check two different implementations of the abstract QCD coupling. <>= call test (sm_qcd_1, "sm_qcd_1", & "running alpha_s", & u, results) <>= public :: sm_qcd_1 <>= subroutine sm_qcd_1 (u) integer, intent(in) :: u type(qcd_t) :: qcd write (u, "(A)") "* Test output: sm_qcd_1" write (u, "(A)") "* Purpose: compute running alpha_s" write (u, "(A)") write (u, "(A)") "* Fixed:" write (u, "(A)") allocate (alpha_qcd_fixed_t :: qcd%alpha) call qcd%compute_alphas_md5sum () call qcd%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha_s (mz) =", & qcd%alpha%get (MZ_REF) write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", & qcd%alpha%get (1000._default) write (u, *) deallocate (qcd%alpha) write (u, "(A)") "* Running from MZ (LO):" write (u, "(A)") allocate (alpha_qcd_from_scale_t :: qcd%alpha) call qcd%compute_alphas_md5sum () call qcd%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha_s (mz) =", & qcd%alpha%get (MZ_REF) write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", & qcd%alpha%get (1000._default) write (u, *) write (u, "(A)") "* Running from MZ (NLO):" write (u, "(A)") select type (alpha => qcd%alpha) type is (alpha_qcd_from_scale_t) alpha%order = 1 end select call qcd%compute_alphas_md5sum () call qcd%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha_s (mz) =", & qcd%alpha%get (MZ_REF) write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", & qcd%alpha%get (1000._default) write (u, *) write (u, "(A)") "* Running from MZ (NNLO):" write (u, "(A)") select type (alpha => qcd%alpha) type is (alpha_qcd_from_scale_t) alpha%order = 2 end select call qcd%compute_alphas_md5sum () call qcd%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha_s (mz) =", & qcd%alpha%get (MZ_REF) write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", & qcd%alpha%get (1000._default) write (u, *) deallocate (qcd%alpha) write (u, "(A)") "* Running from Lambda_QCD (LO):" write (u, "(A)") allocate (alpha_qcd_from_lambda_t :: qcd%alpha) call qcd%compute_alphas_md5sum () call qcd%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha_s (mz) =", & qcd%alpha%get (MZ_REF) write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", & qcd%alpha%get (1000._default) write (u, *) write (u, "(A)") "* Running from Lambda_QCD (NLO):" write (u, "(A)") select type (alpha => qcd%alpha) type is (alpha_qcd_from_lambda_t) alpha%order = 1 end select call qcd%compute_alphas_md5sum () call qcd%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha_s (mz) =", & qcd%alpha%get (MZ_REF) write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", & qcd%alpha%get (1000._default) write (u, *) write (u, "(A)") "* Running from Lambda_QCD (NNLO):" write (u, "(A)") select type (alpha => qcd%alpha) type is (alpha_qcd_from_lambda_t) alpha%order = 2 end select call qcd%compute_alphas_md5sum () call qcd%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha_s (mz) =", & qcd%alpha%get (MZ_REF) write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", & qcd%alpha%get (1000._default) write (u, "(A)") write (u, "(A)") "* Test output end: sm_qcd_1" end subroutine sm_qcd_1 @ %def sm_qcd_1 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{QED Coupling} On the surface similar to the QCD coupling module but much simpler. Only a fixed QED couping $\alpha_\text{em}$ is allowed. Can be extended later if we want to enable a running of $\alpha_\text{em}$ as well. <<[[sm_qed.f90]]>>= <> module sm_qed <> use physics_defs <> <> <> <> interface <> end interface end module sm_qed @ %def sm_qed @ <<[[sm_qed_sub.f90]]>>= <> submodule (sm_qed) sm_qed_s use io_units use format_defs, only: FMT_12 use md5 use sm_physics implicit none contains <> end submodule sm_qed_s @ %def sm_qed_s @ \subsection{Coupling: Abstract Data Type} This is the abstract version of the QCD coupling implementation. <>= public :: alpha_qed_t <>= type, abstract :: alpha_qed_t contains <> end type alpha_qed_t @ %def alpha_qed_t @ There must be an output routine. <>= procedure (alpha_qed_write), deferred :: write <>= abstract interface subroutine alpha_qed_write (object, unit) import class(alpha_qed_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine alpha_qed_write end interface @ %def alpha_qed_write @ This method computes the running coupling, given a certain scale. All parameters (reference value, order of the approximation, etc.) must be set before calling this. <>= procedure (alpha_qed_get), deferred :: get <>= abstract interface function alpha_qed_get (alpha_qed, scale) result (alpha) import class(alpha_qed_t), intent(in) :: alpha_qed real(default), intent(in) :: scale real(default) :: alpha end function alpha_qed_get end interface @ %def alpha_qed_get @ \subsection{Fixed Coupling} In this version, the $\alpha$ value is fixed, the [[scale]] argument of the [[get]] method is ignored. There is only one parameter, the value. The default depends on the electroweak scheme chosen in the model. <>= public :: alpha_qed_fixed_t <>= type, extends (alpha_qed_t) :: alpha_qed_fixed_t real(default) :: val = ALPHA_QED_ME_REF contains <> end type alpha_qed_fixed_t @ %def alpha_qed_fixed_t @ Output. <>= procedure :: write => alpha_qed_fixed_write <>= module subroutine alpha_qed_fixed_write (object, unit) class(alpha_qed_fixed_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine alpha_qed_fixed_write <>= module subroutine alpha_qed_fixed_write (object, unit) class(alpha_qed_fixed_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(3x,A)") "QED parameters (fixed coupling):" write (u, "(5x,A," // FMT_12 // ")") "alpha = ", object%val end subroutine alpha_qed_fixed_write @ %def alpha_qed_fixed_write @ Calculation: the scale is ignored in this case. <>= procedure :: get => alpha_qed_fixed_get <>= module function alpha_qed_fixed_get (alpha_qed, scale) result (alpha) class(alpha_qed_fixed_t), intent(in) :: alpha_qed real(default), intent(in) :: scale real(default) :: alpha end function alpha_qed_fixed_get <>= module function alpha_qed_fixed_get (alpha_qed, scale) result (alpha) class(alpha_qed_fixed_t), intent(in) :: alpha_qed real(default), intent(in) :: scale real(default) :: alpha alpha = alpha_qed%val end function alpha_qed_fixed_get @ %def alpha_qed_fixed_get @ \subsection{Running Coupling} In this version, the $\alpha$ value runs relative to the value at a given reference scale. There are two parameters: the value of this scale (default: $M_Z$), the value of $\alpha$ at this scale, and the number of effective flavors. Furthermore, we have the order of the approximation. <>= public :: alpha_qed_from_scale_t <>= type, extends (alpha_qed_t) :: alpha_qed_from_scale_t real(default) :: mu_ref = ME_REF real(default) :: ref = ALPHA_QED_ME_REF integer :: order = 0 integer :: nf = 5 integer :: nlep = 1 logical :: analytic = .true. contains <> end type alpha_qed_from_scale_t @ %def alpha_qed_from_scale_t @ Output. <>= procedure :: write => alpha_qed_from_scale_write <>= module subroutine alpha_qed_from_scale_write (object, unit) class(alpha_qed_from_scale_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine alpha_qed_from_scale_write <>= module subroutine alpha_qed_from_scale_write (object, unit) class(alpha_qed_from_scale_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(3x,A)") "QED parameters (running coupling):" write (u, "(5x,A," // FMT_12 // ")") "Scale mu = ", object%mu_ref write (u, "(5x,A," // FMT_12 // ")") "alpha(mu) = ", object%ref write (u, "(5x,A,I0)") "LL order = ", object%order write (u, "(5x,A,I0)") "N(flv) = ", object%nf write (u, "(5x,A,I0)") "N(lep) = ", object%nlep write (u, "(5x,A,L1)") "analytic = ", object%analytic end subroutine alpha_qed_from_scale_write @ %def alpha_qed_from_scale_write @ Calculation: here, we call the function for running $\alpha_s$ that was defined in [[sm_physics]] above. The function does not take into account thresholds, so the number of flavors should be the correct one for the chosen scale. Normally, this should be the $Z$ boson mass. <>= procedure :: get => alpha_qed_from_scale_get <>= module function alpha_qed_from_scale_get (alpha_qed, scale) result (alpha) class(alpha_qed_from_scale_t), intent(in) :: alpha_qed real(default), intent(in) :: scale real(default) :: alpha end function alpha_qed_from_scale_get <>= module function alpha_qed_from_scale_get (alpha_qed, scale) result (alpha) class(alpha_qed_from_scale_t), intent(in) :: alpha_qed real(default), intent(in) :: scale real(default) :: alpha if (alpha_qed%analytic) then alpha = running_alpha (scale, alpha_qed%ref, alpha_qed%mu_ref, & alpha_qed%order, alpha_qed%nf, alpha_qed%nlep) else alpha = running_alpha_num (scale, alpha_qed%ref, alpha_qed%mu_ref, & alpha_qed%order, alpha_qed%nf, alpha_qed%nlep) end if end function alpha_qed_from_scale_get @ %def alpha_qed_from_scale_get @ \subsection{QED type} This module is similar to [[qcd_t]], defining the type [[qed_t]]. It stores the [[alpha_qed_t]] type which is either constant or a running $\alpha$ with different options. <>= public :: qed_t <>= type :: qed_t class(alpha_qed_t), allocatable :: alpha character(32) :: md5sum = "" integer :: n_f = -1 integer :: n_lep = -1 contains <> end type qed_t @ %def qed_t Output. We first print the polymorphic [[alpha]] which contains a headline, then any extra components. <>= procedure :: write => qed_write <>= module subroutine qed_write (qed, unit, show_md5sum) class(qed_t), intent(in) :: qed integer, intent(in), optional :: unit logical, intent(in), optional :: show_md5sum end subroutine qed_write <>= module subroutine qed_write (qed, unit, show_md5sum) class(qed_t), intent(in) :: qed integer, intent(in), optional :: unit logical, intent(in), optional :: show_md5sum logical :: show_md5 integer :: u u = given_output_unit (unit); if (u < 0) return show_md5 = .true.; if (present (show_md5sum)) show_md5 = show_md5sum if (allocated (qed%alpha)) then call qed%alpha%write (u) else write (u, "(3x,A)") "QED parameters (coupling undefined)" end if if (show_md5 .and. qed%md5sum /= "") & write (u, "(5x,A,A,A)") "md5sum = '", qed%md5sum, "'" end subroutine qed_write @ % def qed_write @ Compute an MD5 sum for the [[alpha]] setup. This is done by writing them to a temporary file, using a standard format. <>= procedure :: compute_alpha_md5sum => qed_compute_alpha_md5sum <>= module subroutine qed_compute_alpha_md5sum (qed) class(qed_t), intent(inout) :: qed integer :: unit end subroutine qed_compute_alpha_md5sum <>= module subroutine qed_compute_alpha_md5sum (qed) class(qed_t), intent(inout) :: qed integer :: unit if (allocated (qed%alpha)) then unit = free_unit () open (unit, status="scratch", action="readwrite") call qed%alpha%write (unit) rewind (unit) qed%md5sum = md5sum (unit) close (unit) end if end subroutine qed_compute_alpha_md5sum @ %def qed_compute_alphas_md5sum @ @ Retrieve the MD5 sum of the qed setup. <>= procedure :: get_md5sum => qed_get_md5sum <>= module function qed_get_md5sum (qed) result (md5sum) character(32) :: md5sum class(qed_t), intent(inout) :: qed end function qed_get_md5sum <>= module function qed_get_md5sum (qed) result (md5sum) character(32) :: md5sum class(qed_t), intent(inout) :: qed md5sum = qed%md5sum end function qed_get_md5sum @ %def qed_get_md5sum @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sm_qed_ut.f90]]>>= <> module sm_qed_ut use unit_tests use sm_qed_uti <> <> contains <> end module sm_qed_ut @ %def sm_qed_ut @ <<[[sm_qed_uti.f90]]>>= <> module sm_qed_uti <> use physics_defs, only: ME_REF use sm_qed <> <> contains <> end module sm_qed_uti @ %def sm_qed_ut @ API: driver for the unit tests below. <>= public :: sm_qed_test <>= subroutine sm_qed_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sm_qed_test @ %def sm_qed_test @ \subsubsection{QED Coupling} We check two different implementations of the abstract QED coupling. <>= call test (sm_qed_1, "sm_qed_1", & "running alpha_s", & u, results) <>= public :: sm_qed_1 <>= subroutine sm_qed_1 (u) integer, intent(in) :: u type(qed_t) :: qed write (u, "(A)") "* Test output: sm_qed_1" write (u, "(A)") "* Purpose: compute running alpha" write (u, "(A)") write (u, "(A)") "* Fixed:" write (u, "(A)") allocate (alpha_qed_fixed_t :: qed%alpha) call qed%compute_alpha_md5sum () call qed%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha (me) =", & qed%alpha%get (ME_REF) write (u, "(1x,A,F10.7)") "alpha (10 GeV) =", & qed%alpha%get (10._default) write (u, "(1x,A,F10.7)") "alpha (1 TeV) =", & qed%alpha%get (1000._default) write (u, *) deallocate (qed%alpha) write (u, "(A)") "* Running from me (LO):" write (u, "(A)") allocate (alpha_qed_from_scale_t :: qed%alpha) call qed%compute_alpha_md5sum () call qed%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha (me) =", & qed%alpha%get (ME_REF) write (u, "(1x,A,F10.7)") "alpha (10 GeV) =", & qed%alpha%get (10._default) write (u, "(1x,A,F10.7)") "alpha (1 TeV) =", & qed%alpha%get (1000._default) write (u, *) write (u, "(A)") "* Running from me (NLO, analytic):" write (u, "(A)") select type (alpha => qed%alpha) type is (alpha_qed_from_scale_t) alpha%order = 1 end select call qed%compute_alpha_md5sum () call qed%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha (me) =", & qed%alpha%get (ME_REF) write (u, "(1x,A,F10.7)") "alpha (10 GeV) =", & qed%alpha%get (10._default) write (u, "(1x,A,F10.7)") "alpha (1 TeV) =", & qed%alpha%get (1000._default) write (u, *) write (u, "(A)") "* Running from me (NLO, numeric):" write (u, "(A)") select type (alpha => qed%alpha) type is (alpha_qed_from_scale_t) alpha%order = 1 alpha%analytic = .false. end select call qed%compute_alpha_md5sum () call qed%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha (me) =", & qed%alpha%get (ME_REF) write (u, "(1x,A,F10.7)") "alpha (10 GeV) =", & qed%alpha%get (10._default) write (u, "(1x,A,F10.7)") "alpha (1 TeV) =", & qed%alpha%get (1000._default) write (u, *) deallocate (qed%alpha) write (u, "(A)") write (u, "(A)") "* Test output end: sm_qed_1" end subroutine sm_qed_1 @ %def sm_qed_1 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Shower algorithms} <<[[shower_algorithms.f90]]>>= <> module shower_algorithms <> <> <> <> interface <> end interface end module shower_algorithms @ %def shower_algorithms <<[[shower_algorithms_sub.f90]]>>= <> submodule (shower_algorithms) shower_algorithms_s use diagnostics use constants implicit none contains <> <> end submodule shower_algorithms_s @ %def shower_algorithms_s @ @ We want to generate emission variables [[x]]$\in\mathds{R}^d$ proportional to \begin{align} &\quad f(x)\; \Delta(f, h(x)) \quad\text{with}\\ \Delta(f, H) &= \exp\left\{-\int\text{d}^d x'f(x') \Theta(h(x') - H)\right\} \end{align} The [[true_function]] $f$ is however too complicated and we are only able to generate [[x]] according to the [[overestimator]] $F$. This algorithm is described in Appendix B of 0709.2092 and is proven e.g.~in 1211.7204 and hep-ph/0606275. Intuitively speaking, we overestimate the emission probability and can therefore set [[scale_max = scale]] if the emission is rejected. <>= module subroutine generate_vetoed (x, overestimator, true_function, & sudakov, inverse_sudakov, scale_min) real(default), dimension(:), intent(out) :: x !class(rng_t), intent(inout) :: rng procedure(XXX_function), pointer, intent(in) :: overestimator, true_function procedure(sudakov_p), pointer, intent(in) :: sudakov, inverse_sudakov real(default), intent(in) :: scale_min end subroutine generate_vetoed <>= module subroutine generate_vetoed (x, overestimator, true_function, & sudakov, inverse_sudakov, scale_min) real(default), dimension(:), intent(out) :: x !class(rng_t), intent(inout) :: rng procedure(XXX_function), pointer, intent(in) :: overestimator, true_function procedure(sudakov_p), pointer, intent(in) :: sudakov, inverse_sudakov real(default), intent(in) :: scale_min real(default) :: random, scale_max, scale scale_max = inverse_sudakov (one) do while (scale_max > scale_min) !call rng%generate (random) scale = inverse_sudakov (random * sudakov (scale_max)) call generate_on_hypersphere (x, overestimator, scale) !call rng%generate (random) if (random < true_function (x) / overestimator (x)) then return !!! accept x end if scale_max = scale end do end subroutine generate_vetoed @ %def generate_vetoed @ <>= subroutine generate_on_hypersphere (x, overestimator, scale) real(default), dimension(:), intent(out) :: x procedure(XXX_function), pointer, intent(in) :: overestimator real(default), intent(in) :: scale call msg_bug ("generate_on_hypersphere: not implemented") end subroutine generate_on_hypersphere @ %def generate_on_hypersphere @ <>= interface pure function XXX_function (x) import real(default) :: XXX_function real(default), dimension(:), intent(in) :: x end function XXX_function end interface interface pure function sudakov_p (x) import real(default) :: sudakov_p real(default), intent(in) :: x end function sudakov_p end interface @ \subsection{Unit tests} (Currently unused.) <>= public :: shower_algorithms_test <>= subroutine shower_algorithms_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine shower_algorithms_test @ %def shower_algorithms_test @ \subsubsection{Splitting functions} <>= call test (shower_algorithms_1, "shower_algorithms_1", & "veto technique", & u, results) <>= subroutine shower_algorithms_1 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: shower_algorithms_1" write (u, "(A)") "* Purpose: check veto technique" write (u, "(A)") write (u, "(A)") "* Splitting functions:" write (u, "(A)") !call assert (u, vanishes (p_qqg_pol (z, +1, -1, +1))) !call assert (u, nearly_equal ( & !p_qqg_pol (z, +1, +1, -1) + p_qqg_pol (z, +1, +1, +1), !p_qqg (z)) write (u, "(A)") write (u, "(A)") "* Test output end: shower_algorithms_1" end subroutine shower_algorithms_1 @ %def shower_algorithms_1 Index: trunk/src/main/main.nw =================================================================== --- trunk/src/main/main.nw (revision 8815) +++ trunk/src/main/main.nw (revision 8816) @@ -1,2322 +1,2340 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD main code as NOWEB source \includemodulegraph{main} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Main Program} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Tools for the command line} We do not intent to be very smart here, but this module provides a few small tools that simplify dealing with the command line. The [[unquote_value]] subroutine handles an option value that begins with a single/double quote character. It swallows extra option strings until it finds a value that ends with another quote character. The returned string consists of all argument strings between quotes, concatenated by blanks (with a leading blank). Note that more complex patterns, such as quoted or embedded quotes, or multiple blanks, are not accounted for. <<[[cmdline_options.f90]]>>= <> module cmdline_options <> use diagnostics <> public :: init_options public :: no_option_value public :: get_option_value <> abstract interface subroutine msg end subroutine msg end interface procedure (msg), pointer :: print_usage => null () contains subroutine init_options (usage_msg) procedure (msg) :: usage_msg print_usage => usage_msg end subroutine init_options subroutine no_option_value (option, value) type(string_t), intent(in) :: option, value if (value /= "") then call msg_error (" Option '" // char (option) // "' should have no value") end if end subroutine no_option_value function get_option_value (i, option, value) result (string) type(string_t) :: string integer, intent(inout) :: i type(string_t), intent(in) :: option type(string_t), intent(in), optional :: value character(CMDLINE_ARG_LEN) :: arg_value integer :: arg_len, arg_status logical :: has_value if (present (value)) then has_value = value /= "" else has_value = .false. end if if (has_value) then call unquote_value (i, option, value, string) else i = i + 1 call get_command_argument (i, arg_value, arg_len, arg_status) select case (arg_status) case (0) case (-1) call msg_error (" Option value truncated: '" // arg_value // "'") case default call print_usage () call msg_fatal (" Option '" // char (option) // "' needs a value") end select select case (arg_value(1:1)) case ("-") call print_usage () call msg_fatal (" Option '" // char (option) // "' needs a value") end select call unquote_value (i, option, var_str (trim (arg_value)), string) end if end function get_option_value subroutine unquote_value (i, option, value, string) integer, intent(inout) :: i type(string_t), intent(in) :: option type(string_t), intent(in) :: value type(string_t), intent(out) :: string character(1) :: quote character(CMDLINE_ARG_LEN) :: arg_value integer :: arg_len, arg_status quote = extract (value, 1, 1) select case (quote) case ("'", '"') string = "" arg_value = extract (value, 2) arg_len = len_trim (value) APPEND_QUOTED: do if (extract (arg_value, arg_len, arg_len) == quote) then string = string // " " // extract (arg_value, 1, arg_len-1) exit APPEND_QUOTED else string = string // " " // trim (arg_value) i = i + 1 call get_command_argument (i, arg_value, arg_len, arg_status) select case (arg_status) case (0) case (-1) call msg_error (" Quoted option value truncated: '" & // char (string) // "'") case default call print_usage () call msg_fatal (" Option '" // char (option) & // "': unterminated quoted value") end select end if end do APPEND_QUOTED case default string = value end select end subroutine unquote_value end module cmdline_options @ %def init_options @ %def no_option_value @ %def get_option_value @ %def cmdline_options @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Driver program} The main program handles command options, initializes the environment, and runs WHIZARD in a particular mode (interactive, file, standard input). This is also used in the C interface: <>= integer, parameter :: CMDLINE_ARG_LEN = 1000 @ %def CMDLINE_ARG_LEN @ The actual main program: <<[[main.f90]]>>= <> program main <> use system_dependencies use diagnostics use ifiles use os_interface use rt_data, only: show_description_of_string, show_tex_descriptions use whizard use cmdline_options use features <> implicit none <> !!! (WK 02/2016) Interface for the separate external routine below interface subroutine print_usage () end subroutine print_usage end interface ! Main program variable declarations character(CMDLINE_ARG_LEN) :: arg character(2) :: option type(string_t) :: long_option, value integer :: i, j, arg_len, arg_status logical :: look_for_options logical :: interactive logical :: banner type(string_t) :: job_id, files, this, model, default_lib, library, libraries type(string_t) :: logfile, query_string type(paths_t) :: paths type(string_t) :: pack_arg, unpack_arg type(string_t), dimension(:), allocatable :: pack_args, unpack_args type(string_t), dimension(:), allocatable :: tmp_strings logical :: rebuild_library logical :: rebuild_phs, rebuild_grids, rebuild_events logical :: recompile_library type(ifile_t) :: commands type(string_t) :: command, cmdfile integer :: cmdfile_unit logical :: cmdfile_exists type(whizard_options_t), allocatable :: options type(whizard_t), allocatable, target :: whizard_instance ! Exit status logical :: quit = .false. integer :: quit_code = 0 ! Initial values look_for_options = .true. interactive = .false. job_id = "" files = "" model = "SM" default_lib = "default_lib" library = "" libraries = "" banner = .true. logging = .true. msg_level = RESULT logfile = "whizard.log" rebuild_library = .false. rebuild_phs = .false. rebuild_grids = .false. rebuild_events = .false. recompile_library = .false. call paths_init (paths) <> ! Read and process options call init_options (print_usage) i = 0 SCAN_CMDLINE: do i = i + 1 call get_command_argument (i, arg, arg_len, arg_status) select case (arg_status) case (0) case (-1) call msg_error (" Command argument truncated: '" // arg // "'") case default exit SCAN_CMDLINE end select if (look_for_options) then select case (arg(1:2)) case ("--") value = trim (arg) call split (value, long_option, "=") select case (char (long_option)) case ("--version") call no_option_value (long_option, value) call print_version (); stop case ("--help") call no_option_value (long_option, value) call print_usage (); stop case ("--prefix") paths%prefix = get_option_value (i, long_option, value) cycle scan_cmdline case ("--exec-prefix") paths%exec_prefix = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--bindir") paths%bindir = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--libdir") paths%libdir = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--includedir") paths%includedir = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--datarootdir") paths%datarootdir = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--libtool") paths%libtool = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--lhapdfdir") paths%lhapdfdir = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--check") call print_usage () call msg_fatal ("Option --check not supported & &(for unit tests, run whizard_ut instead)") case ("--show-config") call no_option_value (long_option, value) call print_features (); stop case ("--execute") command = get_option_value (i, long_option, value) call ifile_append (commands, command) cycle SCAN_CMDLINE case ("--file") cmdfile = get_option_value (i, long_option, value) inquire (file=char(cmdfile), exist=cmdfile_exists) if (cmdfile_exists) then open (newunit=cmdfile_unit, file=char(cmdfile), & action="read", status="old") call ifile_append (commands, cmdfile_unit) close (cmdfile_unit) else call msg_error & ("Sindarin file '" // char (cmdfile) // "' not found") end if cycle SCAN_CMDLINE case ("--interactive") call no_option_value (long_option, value) interactive = .true. cycle SCAN_CMDLINE case ("--job-id") job_id = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--library") library = get_option_value (i, long_option, value) libraries = libraries // " " // library cycle SCAN_CMDLINE case ("--no-library") call no_option_value (long_option, value) default_lib = "" library = "" libraries = "" cycle SCAN_CMDLINE case ("--localprefix") paths%localprefix = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--logfile") logfile = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--no-logfile") call no_option_value (long_option, value) logfile = "" cycle SCAN_CMDLINE case ("--logging") call no_option_value (long_option, value) logging = .true. cycle SCAN_CMDLINE case ("--no-logging") call no_option_value (long_option, value) logging = .false. cycle SCAN_CMDLINE case ("--query") call no_option_value (long_option, value) query_string = get_option_value (i, long_option, value) call show_description_of_string (query_string) call exit (0) case ("--generate-variables-tex") call no_option_value (long_option, value) call show_tex_descriptions () call exit (0) case ("--debug") call no_option_value (long_option, value) call set_debug_levels (get_option_value (i, long_option, value)) cycle SCAN_CMDLINE case ("--debug2") call no_option_value (long_option, value) call set_debug2_levels (get_option_value (i, long_option, value)) cycle SCAN_CMDLINE case ("--single-event") call no_option_value (long_option, value) single_event = .true. cycle SCAN_CMDLINE case ("--banner") call no_option_value (long_option, value) banner = .true. cycle SCAN_CMDLINE case ("--no-banner") call no_option_value (long_option, value) banner = .false. cycle SCAN_CMDLINE case ("--pack") pack_arg = get_option_value (i, long_option, value) if (allocated (pack_args)) then call move_alloc (from=pack_args, to=tmp_strings) allocate (pack_args (size (tmp_strings)+1)) pack_args(1:size(tmp_strings)) = tmp_strings else allocate (pack_args (1)) end if pack_args(size(pack_args)) = pack_arg cycle SCAN_CMDLINE case ("--unpack") unpack_arg = get_option_value (i, long_option, value) if (allocated (unpack_args)) then call move_alloc (from=unpack_args, to=tmp_strings) allocate (unpack_args (size (tmp_strings)+1)) unpack_args(1:size(tmp_strings)) = tmp_strings else allocate (unpack_args (1)) end if unpack_args(size(unpack_args)) = unpack_arg cycle SCAN_CMDLINE case ("--model") model = get_option_value (i, long_option, value) cycle SCAN_CMDLINE case ("--no-model") call no_option_value (long_option, value) model = "" cycle SCAN_CMDLINE case ("--rebuild") call no_option_value (long_option, value) rebuild_library = .true. rebuild_phs = .true. rebuild_grids = .true. rebuild_events = .true. cycle SCAN_CMDLINE case ("--no-rebuild") call no_option_value (long_option, value) rebuild_library = .false. recompile_library = .false. rebuild_phs = .false. rebuild_grids = .false. rebuild_events = .false. cycle SCAN_CMDLINE case ("--rebuild-library") call no_option_value (long_option, value) rebuild_library = .true. cycle SCAN_CMDLINE case ("--rebuild-phase-space") call no_option_value (long_option, value) rebuild_phs = .true. cycle SCAN_CMDLINE case ("--rebuild-grids") call no_option_value (long_option, value) rebuild_grids = .true. cycle SCAN_CMDLINE case ("--rebuild-events") call no_option_value (long_option, value) rebuild_events = .true. cycle SCAN_CMDLINE case ("--recompile") call no_option_value (long_option, value) recompile_library = .true. rebuild_grids = .true. cycle SCAN_CMDLINE case ("--write-syntax-tables") call no_option_value (long_option, value) call init_syntax_tables () call write_syntax_tables () call final_syntax_tables () stop cycle SCAN_CMDLINE case default call print_usage () call msg_fatal ("Option '" // trim (arg) // "' not recognized") end select end select select case (arg(1:1)) case ("-") j = 1 if (len_trim (arg) == 1) then look_for_options = .false. else SCAN_SHORT_OPTIONS: do j = j + 1 if (j > len_trim (arg)) exit SCAN_SHORT_OPTIONS option = "-" // arg(j:j) select case (option) case ("-V") call print_version (); stop case ("-?", "-h") call print_usage (); stop case ("-e") command = get_option_value (i, var_str (option)) call ifile_append (commands, command) cycle SCAN_CMDLINE case ("-f") cmdfile = get_option_value (i, var_str (option)) inquire (file=char(cmdfile), exist=cmdfile_exists) if (cmdfile_exists) then open (newunit=cmdfile_unit, file=char(cmdfile), & action="read", status="old") call ifile_append (commands, cmdfile_unit) close (cmdfile_unit) else call msg_error ("Sindarin file '" & // char (cmdfile) // "' not found") end if cycle SCAN_CMDLINE case ("-i") interactive = .true. cycle SCAN_SHORT_OPTIONS case ("-J") if (j == len_trim (arg)) then job_id = get_option_value (i, var_str (option)) else job_id = trim (arg(j+1:)) end if cycle SCAN_CMDLINE case ("-l") if (j == len_trim (arg)) then library = get_option_value (i, var_str (option)) else library = trim (arg(j+1:)) end if libraries = libraries // " " // library cycle SCAN_CMDLINE case ("-L") if (j == len_trim (arg)) then logfile = get_option_value (i, var_str (option)) else logfile = trim (arg(j+1:)) end if cycle SCAN_CMDLINE case ("-m") if (j < len_trim (arg)) call msg_fatal & ("Option '" // option // "' needs a value") model = get_option_value (i, var_str (option)) cycle SCAN_CMDLINE case ("-q") call no_option_value (long_option, value) query_string = get_option_value (i, long_option, value) call show_description_of_string (query_string) call exit (0) case ("-r") rebuild_library = .true. rebuild_phs = .true. rebuild_grids = .true. rebuild_events = .true. cycle SCAN_SHORT_OPTIONS case default call print_usage () call msg_fatal & ("Option '" // option // "' not recognized") end select end do SCAN_SHORT_OPTIONS end if case default files = files // " " // trim (arg) end select else files = files // " " // trim (arg) end if end do SCAN_CMDLINE ! Overall initialization if (logfile /= "") call logfile_init (logfile) if (banner) call msg_banner () allocate (options) allocate (whizard_instance) if (.not. quit) then ! Set options and initialize the whizard object options%job_id = job_id if (allocated (pack_args)) then options%pack_args = pack_args else allocate (options%pack_args (0)) end if if (allocated (unpack_args)) then options%unpack_args = unpack_args else allocate (options%unpack_args (0)) end if options%preload_model = model options%default_lib = default_lib options%preload_libraries = libraries options%rebuild_library = rebuild_library options%recompile_library = recompile_library options%rebuild_phs = rebuild_phs options%rebuild_grids = rebuild_grids options%rebuild_events = rebuild_events <> call whizard_instance%init (options, paths, logfile) call mask_term_signals () end if ! Run commands given on the command line if (.not. quit .and. ifile_get_length (commands) > 0) then call whizard_instance%process_ifile (commands, quit, quit_code) end if if (.not. quit) then ! Process commands from standard input if (.not. interactive .and. files == "") then call whizard_instance%process_stdin (quit, quit_code) ! ... or process commands from file else files = trim (adjustl (files)) SCAN_FILES: do while (files /= "") call split (files, this, " ") call whizard_instance%process_file (this, quit, quit_code) if (quit) exit SCAN_FILES end do SCAN_FILES end if end if ! Enter an interactive shell if requested if (.not. quit .and. interactive) then call whizard_instance%shell (quit_code) end if ! Overall finalization call ifile_final (commands) deallocate (options) call whizard_instance%final () deallocate (whizard_instance) <> call terminate_now_if_signal () call release_term_signals () call msg_terminate (quit_code = quit_code) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! contains subroutine print_version () print "(A)", "WHIZARD " // WHIZARD_VERSION print "(A)", "Copyright (C) 1999-2022 Wolfgang Kilian, Thorsten Ohl, Juergen Reuter" print "(A)", " --------------------------------------- " print "(A)", "This is free software; see the source for copying conditions. There is NO" print "(A)", "warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." print * end subroutine print_version end program main !!! (WK 02/2016) !!! Separate subroutine, because this becomes a procedure pointer target !!! Internal procedures as targets are not supported by some compilers. subroutine print_usage () use system_dependencies, only: WHIZARD_VERSION print "(A)", "WHIZARD " // WHIZARD_VERSION print "(A)", "Usage: whizard [OPTIONS] [FILE]" print "(A)", "Run WHIZARD with the command list taken from FILE(s)" print "(A)", "Options for resetting default directories and tools" & // "(GNU naming conventions):" print "(A)", " --prefix DIR" print "(A)", " --exec-prefix DIR" print "(A)", " --bindir DIR" print "(A)", " --libdir DIR" print "(A)", " --includedir DIR" print "(A)", " --datarootdir DIR" print "(A)", " --libtool LOCAL_LIBTOOL" print "(A)", " --lhapdfdir DIR (PDF sets directory)" print "(A)", "Other options:" print "(A)", "-h, --help display this help and exit" print "(A)", " --banner display banner at startup (default)" print "(A)", " --debug AREA switch on debug output for AREA." print "(A)", " AREA can be one of Whizard's src dirs or 'all'" print "(A)", " --debug2 AREA switch on more verbose debug output for AREA." print "(A)", " --single-event only compute one phase-space point (for debugging)" print "(A)", "-e, --execute CMDS execute SINDARIN CMDS before reading FILE(s)" print "(A)", "-f, --file CMDFILE execute SINDARIN from CMDFILE before reading FILE(s)" print "(A)", "-i, --interactive run interactively after reading FILE(s)" print "(A)", "-J, --job-id STRING set job ID to STRING (default: empty)" print "(A)", "-l, --library LIB preload process library NAME" print "(A)", " --localprefix DIR" print "(A)", " search in DIR for local models (default: ~/.whizard)" print "(A)", "-L, --logfile FILE write log to FILE (default: 'whizard.log'" print "(A)", " --logging switch on logging at startup (default)" print "(A)", "-m, --model NAME preload model NAME (default: 'SM')" print "(A)", " --no-banner do not display banner at startup" print "(A)", " --no-library do not preload process library" print "(A)", " --no-logfile do not write a logfile" print "(A)", " --no-logging switch off logging at startup" print "(A)", " --no-model do not preload a model" print "(A)", " --no-rebuild do not force rebuilding" print "(A)", " --pack DIR tar/gzip DIR after job" print "(A)", "-q, --query VARIABLE display documentation of VARIABLE" print "(A)", "-r, --rebuild rebuild all (see below)" print "(A)", " --rebuild-library" print "(A)", " rebuild process code library" print "(A)", " --rebuild-phase-space" print "(A)", " rebuild phase-space configuration" print "(A)", " --rebuild-grids rebuild integration grids" print "(A)", " --rebuild-events rebuild event samples" print "(A)", " --recompile recompile process code" print "(A)", " --show-config show build-time configuration" print "(A)", " --unpack FILE untar/gunzip FILE before job" print "(A)", "-V, --version output version information and exit" print "(A)", " --write-syntax-tables" print "(A)", " write the internal syntax tables to files and exit" print "(A)", "- further options are taken as filenames" print * print "(A)", "With no FILE, read standard input." end subroutine print_usage @ %def main @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Driver program for the unit tests} This is a variant of the above main program that takes unit-test names as command-line options and runs those tests. <<[[main_ut.f90]]>>= <> program main_ut <> use unit_tests use io_units use system_dependencies use diagnostics use os_interface use cmdline_options use model_testbed !NODEP! <> <> implicit none <> !!! (WK 02/2016) Interface for the separate external routine below interface subroutine print_usage () end subroutine print_usage end interface ! Main program variable declarations character(CMDLINE_ARG_LEN) :: arg character(2) :: option type(string_t) :: long_option, value integer :: i, j, arg_len, arg_status logical :: look_for_options logical :: banner type(string_t) :: check, checks type(test_results_t) :: test_results logical :: success ! Exit status integer :: quit_code = 0 ! Initial values look_for_options = .true. banner = .true. logging = .false. msg_level = RESULT check = "" checks = "" <> ! Read and process options call init_options (print_usage) i = 0 SCAN_CMDLINE: do i = i + 1 call get_command_argument (i, arg, arg_len, arg_status) select case (arg_status) case (0) case (-1) call msg_error (" Command argument truncated: '" // arg // "'") case default exit SCAN_CMDLINE end select if (look_for_options) then select case (arg(1:2)) case ("--") value = trim (arg) call split (value, long_option, "=") select case (char (long_option)) case ("--version") call no_option_value (long_option, value) call print_version (); stop case ("--help") call no_option_value (long_option, value) call print_usage (); stop case ("--banner") call no_option_value (long_option, value) banner = .true. cycle SCAN_CMDLINE case ("--no-banner") call no_option_value (long_option, value) banner = .false. cycle SCAN_CMDLINE case ("--check") check = get_option_value (i, long_option, value) checks = checks // " " // check cycle SCAN_CMDLINE case ("--debug") call no_option_value (long_option, value) call set_debug_levels (get_option_value (i, long_option, value)) cycle SCAN_CMDLINE case ("--debug2") call no_option_value (long_option, value) call set_debug2_levels (get_option_value (i, long_option, value)) cycle SCAN_CMDLINE case default call print_usage () call msg_fatal ("Option '" // trim (arg) // "' not recognized") end select end select select case (arg(1:1)) case ("-") j = 1 if (len_trim (arg) == 1) then look_for_options = .false. else SCAN_SHORT_OPTIONS: do j = j + 1 if (j > len_trim (arg)) exit SCAN_SHORT_OPTIONS option = "-" // arg(j:j) select case (option) case ("-V") call print_version (); stop case ("-?", "-h") call print_usage (); stop case default call print_usage () call msg_fatal & ("Option '" // option // "' not recognized") end select end do SCAN_SHORT_OPTIONS end if case default call print_usage () call msg_fatal ("Option '" // trim (arg) // "' not recognized") end select else call print_usage () call msg_fatal ("Option '" // trim (arg) // "' not recognized") end if end do SCAN_CMDLINE ! Overall initialization if (banner) call msg_banner () ! Run any self-checks (and no commands) if (checks /= "") then checks = trim (adjustl (checks)) RUN_CHECKS: do while (checks /= "") call split (checks, check, " ") call whizard_check (check, test_results) end do RUN_CHECKS call test_results%wrapup (6, success) if (.not. success) quit_code = 7 end if <> call msg_terminate (quit_code = quit_code) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! contains subroutine print_version () print "(A)", "WHIZARD " // WHIZARD_VERSION // " (unit test driver)" print "(A)", "Copyright (C) 1999-2022 Wolfgang Kilian, Thorsten Ohl, Juergen Reuter" print "(A)", " --------------------------------------- " print "(A)", "This is free software; see the source for copying conditions. There is NO" print "(A)", "warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." print * end subroutine print_version <> end program main_ut !!! (WK 02/2016) !!! Separate subroutine, because this becomes a procedure pointer target !!! Internal procedures as targets are not supported by some compilers. subroutine print_usage () use system_dependencies, only: WHIZARD_VERSION print "(A)", "WHIZARD " // WHIZARD_VERSION // " (unit test driver)" print "(A)", "Usage: whizard_ut [OPTIONS] [FILE]" print "(A)", "Run WHIZARD unit tests as given on the command line" print "(A)", "Options:" print "(A)", "-h, --help display this help and exit" print "(A)", " --banner display banner at startup (default)" print "(A)", " --no-banner do not display banner at startup" print "(A)", " --debug AREA switch on debug output for AREA." print "(A)", " AREA can be one of Whizard's src dirs or 'all'" print "(A)", " --debug2 AREA switch on more verbose debug output for AREA." print "(A)", "-V, --version output version information and exit" print "(A)", " --check TEST run unit test TEST" end subroutine print_usage @ %def main_ut @ <>= @ <>= @ @ MPI init. <>= call MPI_init () <>= call MPI_finalize () @ %def MPI_init MPI_finalize <>= @ Every rebuild action is forbidden for the slave workers except [[rebuild_grids]], which is handled correctly inside the corresponding integration object. <>= if (.not. mpi_is_comm_master ()) then options%rebuild_library = .false. options%recompile_library = .false. options%rebuild_phs = .false. options%rebuild_events = .false. end if @ \subsection{Self-tests} For those self-tests, we need some auxiliary routines that provide an enviroment. The environment depends on things that are not available at the level of the module that we want to test. \subsubsection{Testbed for event I/O} This subroutine prepares a test process with a single event. All objects are allocated via anonymous pointers, because we want to recover the pointers and delete the objects in a separate procedure. <>= subroutine prepare_eio_test (event, unweighted, n_alt, sample_norm) use variables, only: var_list_t use model_data use process, only: process_t use instances, only: process_instance_t use processes_ut, only: prepare_test_process use event_base use events class(generic_event_t), intent(inout), pointer :: event logical, intent(in), optional :: unweighted integer, intent(in), optional :: n_alt type(string_t), intent(in), optional :: sample_norm type(model_data_t), pointer :: model type(var_list_t) :: var_list type(string_t) :: sample_normalization type(process_t), pointer :: proc type(process_instance_t), pointer :: process_instance allocate (model) call model%init_test () allocate (proc) allocate (process_instance) call prepare_test_process (proc, process_instance, model, & run_id = var_str ("run_test")) call process_instance%setup_event_data () call model%final () deallocate (model) allocate (event_t :: event) select type (event) type is (event_t) if (present (unweighted)) then call var_list%append_log (& var_str ("?unweighted"), unweighted, & intrinsic = .true.) else call var_list%append_log (& var_str ("?unweighted"), .true., & intrinsic = .true.) end if if (present (sample_norm)) then sample_normalization = sample_norm else sample_normalization = var_str ("auto") end if call var_list%append_string (& var_str ("$sample_normalization"), & sample_normalization, intrinsic = .true.) call event%basic_init (var_list, n_alt) call event%connect (process_instance, proc%get_model_ptr ()) call var_list%final () end select end subroutine prepare_eio_test @ %def prepare_eio_test @ Recover those pointers, finalize the objects and deallocate. <>= subroutine cleanup_eio_test (event) use model_data use process, only: process_t use instances, only: process_instance_t use processes_ut, only: cleanup_test_process use event_base use events class(generic_event_t), intent(inout), pointer :: event type(process_t), pointer :: proc type(process_instance_t), pointer :: process_instance select type (event) type is (event_t) proc => event%get_process_ptr () process_instance => event%get_process_instance_ptr () call cleanup_test_process (proc, process_instance) deallocate (process_instance) deallocate (proc) call event%final () end select deallocate (event) end subroutine cleanup_eio_test @ %def cleanup_eio_test_event @ Assign those procedures to appropriate pointers (module variables) in the [[eio_base]] module, so they can be called as if they were module procedures. <>= use eio_base_ut, only: eio_prepare_test use eio_base_ut, only: eio_cleanup_test <>= eio_prepare_test => prepare_eio_test eio_cleanup_test => cleanup_eio_test @ \subsubsection{Any Model} This procedure reads any model from file and, optionally, assigns a var-list pointer. If the model pointer is still null, we allocate the model object first, with concrete type [[model_t]]. This is a service for modules which do just have access to the [[model_data_t]] base type. <>= subroutine prepare_whizard_model (model, name, vars) <> use os_interface use model_data use var_base use models class(model_data_t), intent(inout), pointer :: model type(string_t), intent(in) :: name class(vars_t), pointer, intent(out), optional :: vars type(os_data_t) :: os_data call syntax_model_file_init () call os_data%init () if (.not. associated (model)) allocate (model_t :: model) select type (model) type is (model_t) call model%read (name // ".mdl", os_data) if (present (vars)) then vars => model%get_var_list_ptr () end if end select end subroutine prepare_whizard_model @ %def prepare_whizard_model @ Cleanup after use. Includes deletion of the model-file syntax. <>= subroutine cleanup_whizard_model (model) use model_data use models class(model_data_t), intent(inout), target :: model call model%final () call syntax_model_file_final () end subroutine cleanup_whizard_model @ %def cleanup_whizard_model @ Assign those procedures to appropriate pointers (module variables) in the [[model_testbed]] module, so they can be called as if they were module procedures. <>= prepare_model => prepare_whizard_model cleanup_model => cleanup_whizard_model @ \subsubsection{Fallback model: hadrons} Some event format tests require the hadronic SM implementation, which has to be read from file. We provide the functionality here, so the tests do not depend on model I/O. <>= subroutine prepare_fallback_model (model) use model_data class(model_data_t), intent(inout), pointer :: model call prepare_whizard_model (model, var_str ("SM_hadrons")) end subroutine prepare_fallback_model @ %def prepare_fallback_model @ Assign those procedures to appropriate pointers (module variables) in the [[eio_base]] module, so they can be called as if they were module procedures. <>= use eio_base_ut, only: eio_prepare_fallback_model use eio_base_ut, only: eio_cleanup_fallback_model <>= eio_prepare_fallback_model => prepare_fallback_model eio_cleanup_fallback_model => cleanup_model @ \subsubsection{Access to the test random-number generator} This generator is not normally available for the dispatcher. We assign an additional dispatch routine to the hook in the [[dispatch]] module which will be checked before the default rule. <>= use dispatch_rng, only: dispatch_rng_factory_fallback use dispatch_rng_ut, only: dispatch_rng_factory_test <>= dispatch_rng_factory_fallback => dispatch_rng_factory_test @ \subsubsection{Access to the test structure functions} These are not normally available for the dispatcher. We assign an additional dispatch routine to the hook in the [[dispatch]] module which will be checked before the default rule. <>= use dispatch_beams, only: dispatch_sf_data_extra use dispatch_ut, only: dispatch_sf_data_test <>= dispatch_sf_data_extra => dispatch_sf_data_test @ \subsubsection{Procedure for Checking} This is for developers only, but needs a well-defined interface. <>= subroutine whizard_check (check, results) type(string_t), intent(in) :: check type(test_results_t), intent(inout) :: results type(os_data_t) :: os_data integer :: u call os_data%init () u = free_unit () open (u, file="whizard_check." // char (check) // ".log", & action="write", status="replace") call msg_message (repeat ('=', 76), 0) call msg_message ("Running self-test: " // char (check), 0) call msg_message (repeat ('-', 76), 0) <> select case (char (check)) <> case ("all") <> case default call msg_fatal ("Self-test '" // char (check) // "' not implemented.") end select close (u) end subroutine whizard_check @ %def whizard_check @ \subsection{Unit test references} \subsubsection{Formats} <>= use formats_ut, only: format_test <>= case ("formats") call format_test (u, results) <>= call format_test (u, results) @ +\subsubsection{Numeric utilities} +<>= + use numeric_utils_ut, only: numeric_utils_test +<>= + case ("numeric_utils") + call numeric_utils_test (u, results) +<>= + call numeric_utils_test (u, results) +@ \subsubsection{Binary Tree} <>= use binary_tree_ut, only: binary_tree_test <>= case ("binary_tree") call binary_tree_test (u, results) <>= call binary_tree_test (u, results) @ \subsubsection{Array List} <>= use array_list_ut, only: array_list_test <>= case ("array_list") call array_list_test (u, results) <>= call array_list_test (u, results) @ \subsubsection{Iterator} <>= use iterator_ut, only: iterator_test <>= case ("iterator") call iterator_test (u, results) <>= call iterator_test (u, results) @ \subsubsection{MD5} <>= use md5_ut, only: md5_test <>= case ("md5") call md5_test (u, results) <>= call md5_test (u, results) @ \subsubsection{OS Interface} <>= use os_interface_ut, only: os_interface_test <>= case ("os_interface") call os_interface_test (u, results) <>= call os_interface_test (u, results) @ \subsubsection{Sorting} <>= use sorting_ut, only: sorting_test <>= case ("sorting") call sorting_test (u, results) <>= call sorting_test (u, results) @ \subsubsection{Grids} <>= use grids_ut, only: grids_test <>= case ("grids") call grids_test (u, results) <>= call grids_test (u, results) @ \subsubsection{Solver} <>= use solver_ut, only: solver_test <>= case ("solver") call solver_test (u, results) <>= call solver_test (u, results) @ \subsubsection{CPU Time} <>= use cputime_ut, only: cputime_test <>= case ("cputime") call cputime_test (u, results) <>= call cputime_test (u, results) @ \subsubsection{PHS points} <>= use phs_points_ut, only: phs_points_test <>= case ("phs_points") call phs_points_test (u, results) <>= call phs_points_test (u, results) @ \subsubsection{SM QCD} <>= use sm_qcd_ut, only: sm_qcd_test <>= case ("sm_qcd") call sm_qcd_test (u, results) <>= call sm_qcd_test (u, results) @ \subsubsection{SM QED} <>= use sm_qed_ut, only: sm_qed_test <>= case ("sm_qed") call sm_qed_test (u, results) <>= call sm_qed_test (u, results) @ \subsubsection{SM physics} <>= use sm_physics_ut, only: sm_physics_test <>= case ("sm_physics") call sm_physics_test (u, results) <>= call sm_physics_test (u, results) @ +\subsubsection{Electron PDFs} +<>= + use electron_pdfs_ut, only: electron_pdfs_test +<>= + case ("electron_pdfs") + call electron_pdfs_test (u, results) +<>= + call electron_pdfs_test (u, results) +@ \subsubsection{Lexers} <>= use lexers_ut, only: lexer_test <>= case ("lexers") call lexer_test (u, results) <>= call lexer_test (u, results) @ \subsubsection{Parser} <>= use parser_ut, only: parse_test <>= case ("parser") call parse_test (u, results) <>= call parse_test (u, results) @ \subsubsection{XML} <>= use xml_ut, only: xml_test <>= case ("xml") call xml_test (u, results) <>= call xml_test (u, results) @ \subsubsection{Colors} <>= use colors_ut, only: color_test <>= case ("colors") call color_test (u, results) <>= call color_test (u, results) @ \subsubsection{State matrices} <>= use state_matrices_ut, only: state_matrix_test <>= case ("state_matrices") call state_matrix_test (u, results) <>= call state_matrix_test (u, results) @ \subsubsection{Analysis} <>= use analysis_ut, only: analysis_test <>= case ("analysis") call analysis_test (u, results) <>= call analysis_test (u, results) @ \subsubsection{Particles} <>= use particles_ut, only: particles_test <>= case ("particles") call particles_test (u, results) <>= call particles_test (u, results) @ \subsubsection{Models} <>= use models_ut, only: models_test <>= case ("models") call models_test (u, results) <>= call models_test (u, results) @ \subsubsection{Auto Components} <>= use auto_components_ut, only: auto_components_test <>= case ("auto_components") call auto_components_test (u, results) <>= call auto_components_test (u, results) @ \subsubsection{Radiation Generator} <>= use radiation_generator_ut, only: radiation_generator_test <>= case ("radiation_generator") call radiation_generator_test (u, results) <>= call radiation_generator_test (u, results) @ \subsection{BLHA} <>= use blha_ut, only: blha_test <>= case ("blha") call blha_test (u, results) <>= call blha_test (u, results) @ \subsubsection{Evaluators} <>= use evaluators_ut, only: evaluator_test <>= case ("evaluators") call evaluator_test (u, results) <>= call evaluator_test (u, results) @ \subsubsection{Expressions} <>= use eval_trees_ut, only: expressions_test <>= case ("expressions") call expressions_test (u, results) <>= call expressions_test (u, results) @ \subsubsection{Resonances} <>= use resonances_ut, only: resonances_test <>= case ("resonances") call resonances_test (u, results) <>= call resonances_test (u, results) @ \subsubsection{PHS Trees} <>= use phs_trees_ut, only: phs_trees_test <>= case ("phs_trees") call phs_trees_test (u, results) <>= call phs_trees_test (u, results) @ \subsubsection{PHS Forests} <>= use phs_forests_ut, only: phs_forests_test <>= case ("phs_forests") call phs_forests_test (u, results) <>= call phs_forests_test (u, results) @ \subsubsection{Beams} <>= use beams_ut, only: beams_test <>= case ("beams") call beams_test (u, results) <>= call beams_test (u, results) @ \subsubsection{$su(N)$ Algebra} <>= use su_algebra_ut, only: su_algebra_test <>= case ("su_algebra") call su_algebra_test (u, results) <>= call su_algebra_test (u, results) @ \subsubsection{Bloch Vectors} <>= use bloch_vectors_ut, only: bloch_vectors_test <>= case ("bloch_vectors") call bloch_vectors_test (u, results) <>= call bloch_vectors_test (u, results) @ \subsubsection{Polarizations} <>= use polarizations_ut, only: polarizations_test <>= case ("polarizations") call polarizations_test (u, results) <>= call polarizations_test (u, results) @ \subsubsection{SF Aux} <>= use sf_aux_ut, only: sf_aux_test <>= case ("sf_aux") call sf_aux_test (u, results) <>= call sf_aux_test (u, results) @ \subsubsection{SF Mappings} <>= use sf_mappings_ut, only: sf_mappings_test <>= case ("sf_mappings") call sf_mappings_test (u, results) <>= call sf_mappings_test (u, results) @ \subsubsection{SF Base} <>= use sf_base_ut, only: sf_base_test <>= case ("sf_base") call sf_base_test (u, results) <>= call sf_base_test (u, results) @ \subsubsection{SF PDF Builtin} <>= use sf_pdf_builtin_ut, only: sf_pdf_builtin_test <>= case ("sf_pdf_builtin") call sf_pdf_builtin_test (u, results) <>= call sf_pdf_builtin_test (u, results) @ \subsubsection{SF LHAPDF} <>= use sf_lhapdf_ut, only: sf_lhapdf_test <>= case ("sf_lhapdf") call sf_lhapdf_test (u, results) <>= call sf_lhapdf_test (u, results) @ \subsubsection{SF ISR} <>= use sf_isr_ut, only: sf_isr_test <>= case ("sf_isr") call sf_isr_test (u, results) <>= call sf_isr_test (u, results) @ \subsubsection{SF EPA} <>= use sf_epa_ut, only: sf_epa_test <>= case ("sf_epa") call sf_epa_test (u, results) <>= call sf_epa_test (u, results) @ \subsubsection{SF EWA} <>= use sf_ewa_ut, only: sf_ewa_test <>= case ("sf_ewa") call sf_ewa_test (u, results) <>= call sf_ewa_test (u, results) @ \subsubsection{SF CIRCE1} <>= use sf_circe1_ut, only: sf_circe1_test <>= case ("sf_circe1") call sf_circe1_test (u, results) <>= call sf_circe1_test (u, results) @ \subsubsection{SF CIRCE2} <>= use sf_circe2_ut, only: sf_circe2_test <>= case ("sf_circe2") call sf_circe2_test (u, results) <>= call sf_circe2_test (u, results) @ \subsubsection{SF Gaussian} <>= use sf_gaussian_ut, only: sf_gaussian_test <>= case ("sf_gaussian") call sf_gaussian_test (u, results) <>= call sf_gaussian_test (u, results) @ \subsubsection{SF Beam Events} <>= use sf_beam_events_ut, only: sf_beam_events_test <>= case ("sf_beam_events") call sf_beam_events_test (u, results) <>= call sf_beam_events_test (u, results) @ \subsubsection{SF EScan} <>= use sf_escan_ut, only: sf_escan_test <>= case ("sf_escan") call sf_escan_test (u, results) <>= call sf_escan_test (u, results) @ \subsubsection{PHS Base} <>= use phs_base_ut, only: phs_base_test <>= case ("phs_base") call phs_base_test (u, results) <>= call phs_base_test (u, results) @ \subsubsection{PHS None} <>= use phs_none_ut, only: phs_none_test <>= case ("phs_none") call phs_none_test (u, results) <>= call phs_none_test (u, results) @ \subsubsection{PHS Single} <>= use phs_single_ut, only: phs_single_test <>= case ("phs_single") call phs_single_test (u, results) <>= call phs_single_test (u, results) @ \subsubsection{PHS Rambo} <>= use phs_rambo_ut, only: phs_rambo_test <>= case ("phs_rambo") call phs_rambo_test (u, results) <>= call phs_rambo_test (u, results) @ \subsubsection{PHS Wood} <>= use phs_wood_ut, only: phs_wood_test use phs_wood_ut, only: phs_wood_vis_test <>= case ("phs_wood") call phs_wood_test (u, results) case ("phs_wood_vis") call phs_wood_vis_test (u, results) <>= call phs_wood_test (u, results) call phs_wood_vis_test (u, results) @ \subsubsection{PHS FKS Generator} <>= use phs_fks_ut, only: phs_fks_generator_test <>= case ("phs_fks_generator") call phs_fks_generator_test (u, results) <>= call phs_fks_generator_test (u, results) @ \subsubsection{FKS regions} <>= use fks_regions_ut, only: fks_regions_test <>= case ("fks_regions") call fks_regions_test (u, results) <>= call fks_regions_test (u, results) @ \subsubsection{Real subtraction} <>= use real_subtraction_ut, only: real_subtraction_test <>= case ("real_subtraction") call real_subtraction_test (u, results) <>= call real_subtraction_test (u, results) @ \subsubsection{RECOLA} <>= use prc_recola_ut, only: prc_recola_test <>= case ("prc_recola") call prc_recola_test (u, results) <>= call prc_recola_test (u, results) @ \subsubsection{RNG Base} <>= use rng_base_ut, only: rng_base_test <>= case ("rng_base") call rng_base_test (u, results) <>= call rng_base_test (u, results) @ \subsubsection{RNG Tao} <>= use rng_tao_ut, only: rng_tao_test <>= case ("rng_tao") call rng_tao_test (u, results) <>= call rng_tao_test (u, results) @ \subsubsection{RNG Stream} <>= use rng_stream_ut, only: rng_stream_test <>= case ("rng_stream") call rng_stream_test (u, results) <>= call rng_stream_test (u, results) @ \subsubsection{Selectors} <>= use selectors_ut, only: selectors_test <>= case ("selectors") call selectors_test (u, results) <>= call selectors_test (u, results) @ \subsubsection{VEGAS} <>= use vegas_ut, only: vegas_test <>= case ("vegas") call vegas_test (u, results) <>= call vegas_test (u, results) @ \subsubsection{VAMP2} <>= use vamp2_ut, only: vamp2_test <>= case ("vamp2") call vamp2_test (u, results) <>= call vamp2_test (u, results) @ \subsubsection{MCI Base} <>= use mci_base_ut, only: mci_base_test <>= case ("mci_base") call mci_base_test (u, results) <>= call mci_base_test (u, results) @ \subsubsection{MCI None} <>= use mci_none_ut, only: mci_none_test <>= case ("mci_none") call mci_none_test (u, results) <>= call mci_none_test (u, results) @ \subsubsection{MCI Midpoint} <>= use mci_midpoint_ut, only: mci_midpoint_test <>= case ("mci_midpoint") call mci_midpoint_test (u, results) <>= call mci_midpoint_test (u, results) @ \subsubsection{MCI VAMP} <>= use mci_vamp_ut, only: mci_vamp_test <>= case ("mci_vamp") call mci_vamp_test (u, results) <>= call mci_vamp_test (u, results) @ \subsubsection{MCI VAMP2} <>= use mci_vamp2_ut, only: mci_vamp2_test <>= case ("mci_vamp2") call mci_vamp2_test (u, results) <>= call mci_vamp2_test (u, results) @ \subsubsection{Integration Results} <>= use integration_results_ut, only: integration_results_test <>= case ("integration_results") call integration_results_test (u, results) <>= call integration_results_test (u, results) @ \subsubsection{PRCLib Interfaces} <>= use prclib_interfaces_ut, only: prclib_interfaces_test <>= case ("prclib_interfaces") call prclib_interfaces_test (u, results) <>= call prclib_interfaces_test (u, results) @ \subsubsection{Particle Specifiers} <>= use particle_specifiers_ut, only: particle_specifiers_test <>= case ("particle_specifiers") call particle_specifiers_test (u, results) <>= call particle_specifiers_test (u, results) @ \subsubsection{Process Libraries} <>= use process_libraries_ut, only: process_libraries_test <>= case ("process_libraries") call process_libraries_test (u, results) <>= call process_libraries_test (u, results) @ \subsubsection{PRCLib Stacks} <>= use prclib_stacks_ut, only: prclib_stacks_test <>= case ("prclib_stacks") call prclib_stacks_test (u, results) <>= call prclib_stacks_test (u, results) @ \subsubsection{HepMC} <>= use hepmc_interface_ut, only: hepmc_interface_test <>= case ("hepmc") call hepmc_interface_test (u, results) <>= call hepmc_interface_test (u, results) @ \subsubsection{LCIO} <>= use lcio_interface_ut, only: lcio_interface_test <>= case ("lcio") call lcio_interface_test (u, results) <>= call lcio_interface_test (u, results) @ \subsubsection{Jets} <>= use jets_ut, only: jets_test <>= case ("jets") call jets_test (u, results) <>= call jets_test (u, results) @ \subsection{LHA User Process WHIZARD} <>= use whizard_lha_ut, only: whizard_lha_test <>= case ("whizard_lha") call whizard_lha_test (u, results) <>= call whizard_lha_test (u, results) @ \subsection{Pythia8} <>= use pythia8_ut, only: pythia8_test <>= case ("pythia8") call pythia8_test (u, results) <>= call pythia8_test (u, results) @ \subsubsection{PDG Arrays} <>= use pdg_arrays_ut, only: pdg_arrays_test <>= case ("pdg_arrays") call pdg_arrays_test (u, results) <>= call pdg_arrays_test (u, results) @ \subsubsection{interactions} <>= use interactions_ut, only: interaction_test <>= case ("interactions") call interaction_test (u, results) <>= call interaction_test (u, results) @ \subsubsection{SLHA} <>= use slha_interface_ut, only: slha_test <>= case ("slha_interface") call slha_test (u, results) <>= call slha_test (u, results) @ \subsubsection{Cascades} <>= use cascades_ut, only: cascades_test <>= case ("cascades") call cascades_test (u, results) <>= call cascades_test (u, results) @ \subsubsection{Cascades2 lexer} <>= use cascades2_lexer_ut, only: cascades2_lexer_test <>= case ("cascades2_lexer") call cascades2_lexer_test (u, results) <>= call cascades2_lexer_test (u, results) @ \subsubsection{Cascades2} <>= use cascades2_ut, only: cascades2_test <>= case ("cascades2") call cascades2_test (u, results) <>= call cascades2_test (u, results) @ \subsubsection{PRC Test} <>= use prc_test_ut, only: prc_test_test <>= case ("prc_test") call prc_test_test (u, results) <>= call prc_test_test (u, results) @ \subsubsection{PRC Template ME} <>= use prc_template_me_ut, only: prc_template_me_test <>= case ("prc_template_me") call prc_template_me_test (u, results) <>= call prc_template_me_test (u, results) @ \subsubsection{PRC OMega} <>= use prc_omega_ut, only: prc_omega_test use prc_omega_ut, only: prc_omega_diags_test <>= case ("prc_omega") call prc_omega_test (u, results) case ("prc_omega_diags") call prc_omega_diags_test (u, results) <>= call prc_omega_test (u, results) call prc_omega_diags_test (u, results) @ \subsubsection{Parton States} <>= use parton_states_ut, only: parton_states_test <>= case ("parton_states") call parton_states_test (u, results) <>= call parton_states_test (u, results) @ \subsubsection{Subevt Expr} <>= use expr_tests_ut, only: subevt_expr_test <>= case ("subevt_expr") call subevt_expr_test (u, results) <>= call subevt_expr_test (u, results) @ \subsubsection{Processes} <>= use processes_ut, only: processes_test <>= case ("processes") call processes_test (u, results) <>= call processes_test (u, results) @ \subsubsection{Process Stacks} <>= use process_stacks_ut, only: process_stacks_test <>= case ("process_stacks") call process_stacks_test (u, results) <>= call process_stacks_test (u, results) @ \subsubsection{Event Transforms} <>= use event_transforms_ut, only: event_transforms_test <>= case ("event_transforms") call event_transforms_test (u, results) <>= call event_transforms_test (u, results) @ \subsubsection{Resonance Insertion Transform} <>= use resonance_insertion_ut, only: resonance_insertion_test <>= case ("resonance_insertion") call resonance_insertion_test (u, results) <>= call resonance_insertion_test (u, results) @ \subsubsection{Recoil Kinematics} <>= use recoil_kinematics_ut, only: recoil_kinematics_test <>= case ("recoil_kinematics") call recoil_kinematics_test (u, results) <>= call recoil_kinematics_test (u, results) @ \subsubsection{ISR Handler} <>= use isr_epa_handler_ut, only: isr_handler_test <>= case ("isr_handler") call isr_handler_test (u, results) <>= call isr_handler_test (u, results) @ \subsubsection{EPA Handler} <>= use isr_epa_handler_ut, only: epa_handler_test <>= case ("epa_handler") call epa_handler_test (u, results) <>= call epa_handler_test (u, results) @ \subsubsection{Decays} <>= use decays_ut, only: decays_test <>= case ("decays") call decays_test (u, results) <>= call decays_test (u, results) @ \subsubsection{Shower} <>= use shower_ut, only: shower_test <>= case ("shower") call shower_test (u, results) <>= call shower_test (u, results) @ \subsubsection{Events} <>= use events_ut, only: events_test <>= case ("events") call events_test (u, results) <>= call events_test (u, results) @ \subsubsection{HEP Events} <>= use hep_events_ut, only: hep_events_test <>= case ("hep_events") call hep_events_test (u, results) <>= call hep_events_test (u, results) @ \subsubsection{EIO Data} <>= use eio_data_ut, only: eio_data_test <>= case ("eio_data") call eio_data_test (u, results) <>= call eio_data_test (u, results) @ \subsubsection{EIO Base} <>= use eio_base_ut, only: eio_base_test <>= case ("eio_base") call eio_base_test (u, results) <>= call eio_base_test (u, results) @ \subsubsection{EIO Direct} <>= use eio_direct_ut, only: eio_direct_test <>= case ("eio_direct") call eio_direct_test (u, results) <>= call eio_direct_test (u, results) @ \subsubsection{EIO Raw} <>= use eio_raw_ut, only: eio_raw_test <>= case ("eio_raw") call eio_raw_test (u, results) <>= call eio_raw_test (u, results) @ \subsubsection{EIO Checkpoints} <>= use eio_checkpoints_ut, only: eio_checkpoints_test <>= case ("eio_checkpoints") call eio_checkpoints_test (u, results) <>= call eio_checkpoints_test (u, results) @ \subsubsection{EIO LHEF} <>= use eio_lhef_ut, only: eio_lhef_test <>= case ("eio_lhef") call eio_lhef_test (u, results) <>= call eio_lhef_test (u, results) @ \subsubsection{EIO HepMC} <>= use eio_hepmc_ut, only: eio_hepmc_test <>= case ("eio_hepmc") call eio_hepmc_test (u, results) <>= call eio_hepmc_test (u, results) @ \subsubsection{EIO LCIO} <>= use eio_lcio_ut, only: eio_lcio_test <>= case ("eio_lcio") call eio_lcio_test (u, results) <>= call eio_lcio_test (u, results) @ \subsubsection{EIO StdHEP} <>= use eio_stdhep_ut, only: eio_stdhep_test <>= case ("eio_stdhep") call eio_stdhep_test (u, results) <>= call eio_stdhep_test (u, results) @ \subsubsection{EIO ASCII} <>= use eio_ascii_ut, only: eio_ascii_test <>= case ("eio_ascii") call eio_ascii_test (u, results) <>= call eio_ascii_test (u, results) @ \subsubsection{EIO Weights} <>= use eio_weights_ut, only: eio_weights_test <>= case ("eio_weights") call eio_weights_test (u, results) <>= call eio_weights_test (u, results) @ \subsubsection{EIO Dump} <>= use eio_dump_ut, only: eio_dump_test <>= case ("eio_dump") call eio_dump_test (u, results) <>= call eio_dump_test (u, results) @ \subsubsection{Iterations} <>= use iterations_ut, only: iterations_test <>= case ("iterations") call iterations_test (u, results) <>= call iterations_test (u, results) @ \subsubsection{Beam Structures} <>= use beam_structures_ut, only: beam_structures_test <>= case ("beam_structures") call beam_structures_test (u, results) <>= call beam_structures_test (u, results) @ \subsubsection{RT Data} <>= use rt_data_ut, only: rt_data_test <>= case ("rt_data") call rt_data_test (u, results) <>= call rt_data_test (u, results) @ \subsubsection{Dispatch} <>= use dispatch_ut, only: dispatch_test <>= case ("dispatch") call dispatch_test (u, results) <>= call dispatch_test (u, results) @ \subsubsection{Dispatch RNG} <>= use dispatch_rng_ut, only: dispatch_rng_test <>= case ("dispatch_rng") call dispatch_rng_test (u, results) <>= call dispatch_rng_test (u, results) @ \subsubsection{Dispatch MCI} <>= use dispatch_mci_ut, only: dispatch_mci_test <>= case ("dispatch_mci") call dispatch_mci_test (u, results) <>= call dispatch_mci_test (u, results) @ \subsubsection{Dispatch PHS} <>= use dispatch_phs_ut, only: dispatch_phs_test <>= case ("dispatch_phs") call dispatch_phs_test (u, results) <>= call dispatch_phs_test (u, results) @ \subsubsection{Dispatch transforms} <>= use dispatch_transforms_ut, only: dispatch_transforms_test <>= case ("dispatch_transforms") call dispatch_transforms_test (u, results) <>= call dispatch_transforms_test (u, results) @ \subsubsection{Shower partons} <>= use shower_base_ut, only: shower_base_test <>= case ("shower_base") call shower_base_test (u, results) <>= call shower_base_test (u, results) @ \subsubsection{Process Configurations} <>= use process_configurations_ut, only: process_configurations_test <>= case ("process_configurations") call process_configurations_test (u, results) <>= call process_configurations_test (u, results) @ \subsubsection{Compilations} <>= use compilations_ut, only: compilations_test use compilations_ut, only: compilations_static_test <>= case ("compilations") call compilations_test (u, results) case ("compilations_static") call compilations_static_test (u, results) <>= call compilations_test (u, results) call compilations_static_test (u, results) @ \subsubsection{Integrations} <>= use integrations_ut, only: integrations_test use integrations_ut, only: integrations_history_test <>= case ("integrations") call integrations_test (u, results) case ("integrations_history") call integrations_history_test (u, results) <>= call integrations_test (u, results) call integrations_history_test (u, results) @ \subsubsection{Event Streams} <>= use event_streams_ut, only: event_streams_test <>= case ("event_streams") call event_streams_test (u, results) <>= call event_streams_test (u, results) @ \subsubsection{Restricted Subprocesses} <>= use restricted_subprocesses_ut, only: restricted_subprocesses_test <>= case ("restricted_subprocesses") call restricted_subprocesses_test (u, results) <>= call restricted_subprocesses_test (u, results) @ \subsubsection{Simulations} <>= use simulations_ut, only: simulations_test <>= case ("simulations") call simulations_test (u, results) <>= call simulations_test (u, results) @ \subsubsection{Commands} <>= use commands_ut, only: commands_test <>= case ("commands") call commands_test (u, results) <>= call commands_test (u, results) @ \subsubsection{$ttV$ formfactors} <>= use ttv_formfactors_ut, only: ttv_formfactors_test <>= case ("ttv_formfactors") call ttv_formfactors_test (u, results) <>= call ttv_formfactors_test (u, results) @ \subsubsection{API} <>= use api_ut, only: api_test <>= case ("api") call api_test (u, results) <>= call api_test (u, results) @ \subsubsection{API/HepMC} <>= use api_hepmc_ut, only: api_hepmc_test <>= case ("api_hepmc") call api_hepmc_test (u, results) <>= call api_hepmc_test (u, results) @ \subsubsection{API/LCIO} <>= use api_lcio_ut, only: api_lcio_test <>= case ("api_lcio") call api_lcio_test (u, results) <>= call api_lcio_test (u, results) Index: trunk/src/main/Makefile.am =================================================================== --- trunk/src/main/Makefile.am (revision 8815) +++ trunk/src/main/Makefile.am (revision 8816) @@ -1,270 +1,271 @@ ## Makefile.am -- Makefile for WHIZARD ## ## Process this file with automake to produce Makefile.in # # Copyright (C) 1999-2022 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## ## The main program is contained in a library on its own. lib_LTLIBRARIES = libwhizard_main.la check_LTLIBRARIES = libwhizard_main_ut.la COMMON_F90 = \ cmdline_options.f90 MPI_F90 = \ main.f90_mpi SERIAL_F90 = \ main.f90_serial nodist_libwhizard_main_la_SOURCES = \ $(COMMON_F90) \ main.f90 DISTCLEANFILES = main.f90 if FC_USE_MPI main.f90: main.f90_mpi -cp -f $< $@ else main.f90: main.f90_serial -cp -f $< $@ endif MPI_F90 += main_ut.f90_mpi SERIAL_F90 += main_ut.f90_serial nodist_libwhizard_main_ut_la_SOURCES = \ $(COMMON_F90) \ main_ut.f90 DISTCLEANFILES += main_ut.f90 if FC_USE_MPI main_ut.f90: main_ut.f90_mpi -cp -f $< $@ else main_ut.f90: main_ut.f90_serial -cp -f $< $@ endif EXTRA_DIST = \ $(COMMON_F90) \ $(SERIAL_F90) \ $(MPI_F90) ## Omitting this would exclude it from the distribution dist_noinst_DATA = main.nw # # Dump module names into file Modules # libwhizard_core_Modules = \ # ${libwhizard_core_la_SOURCES:.f90=} \ # ${nodist_libwhizard_core_la_SOURCES:.f90=} \ # ${libwhizard_core_ut_la_SOURCES:.f90=} # Modules: Makefile # @for module in $(libwhizard_core_Modules); do \ # echo $$module >> $@.new; \ # done # @if diff $@ $@.new -q >/dev/null; then \ # rm $@.new; \ # else \ # mv $@.new $@; echo "Modules updated"; \ # fi # BUILT_SOURCES = Modules ## Fortran module dependencies # Get module lists from other directories module_lists = \ ../basics/Modules \ ../utilities/Modules \ ../testing/Modules \ ../system/Modules \ ../combinatorics/Modules \ ../parsing/Modules \ ../rng/Modules \ ../physics/Modules \ + ../qed_pdf/Modules \ ../qft/Modules \ ../expr_base/Modules \ ../types/Modules \ ../matrix_elements/Modules \ ../particles/Modules \ ../beams/Modules \ ../me_methods/Modules \ ../pythia8/Modules \ ../events/Modules \ ../phase_space/Modules \ ../mci/Modules \ ../vegas/Modules \ ../blha/Modules \ ../gosam/Modules \ ../openloops/Modules \ ../recola/Modules \ ../fks/Modules \ ../variables/Modules \ ../model_features/Modules \ ../muli/Modules \ ../shower/Modules \ ../matching/Modules \ ../process_integration/Modules \ ../transforms/Modules \ ../threshold/Modules \ ../whizard-core/Modules \ ../api/Modules $(module_lists): $(MAKE) -C `dirname $@` Modules Module_dependencies.sed: \ $(nodist_libwhizard_main_la_SOURCES) \ $(nodist_libwhizard_main_ut_la_SOURCES) Module_dependencies.sed: $(module_lists) @rm -f $@ echo 's/, *only:.*//' >> $@ echo 's/, *&//' >> $@ echo 's/, *.*=>.*//' >> $@ echo 's/$$/.lo/' >> $@ for list in $(module_lists); do \ dir="`dirname $$list`"; \ for mod in `cat $$list`; do \ echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \ done \ done DISTCLEANFILES += Module_dependencies.sed # The following line just says # include Makefile.depend # but in a portable fashion (depending on automake's AM_MAKE_INCLUDE @am__include@ @am__quote@Makefile.depend@am__quote@ Makefile.depend: Module_dependencies.sed Makefile.depend: \ $(nodist_libwhizard_main_la_SOURCES) \ $(nodist_libwhizard_main_ut_la_SOURCES) @rm -f $@ for src in $^; do \ module="`basename $$src | sed 's/\.f[90][0358]//'`"; \ grep '^ *use ' $$src \ | grep -v '!NODEP!' \ | sed -e 's/^ *use */'$$module'.lo: /' \ -f Module_dependencies.sed; \ done > $@ DISTCLEANFILES += Makefile.depend SUFFIXES = .lo .$(FCMOD) # Fortran90 module files are generated at the same time as object files .lo.$(FCMOD): @: # touch $@ AM_FCFLAGS = -I../basics -I../utilities -I../testing -I../system -I../combinatorics -I../parsing -I../rng -I../physics -I../qed_pdf -I../qft -I../expr_base -I../types -I../matrix_elements -I../particles -I../beams -I../me_methods -I../events -I../phase_space -I../mci -I../vegas -I../blha -I../gosam -I../openloops -I../fks -I../variables -I../model_features -I../muli -I../pythia8 -I../shower -I../matching -I../process_integration -I../transforms -I../xdr -I../../vamp/src -I../pdf_builtin -I../../circe1/src -I../../circe2/src -I../lhapdf -I../fastjet -I../threshold -I../tauola -I../recola -I../whizard-core -I../api ######################################################################## ## Default Fortran compiler options ## Profiling if FC_USE_PROFILING AM_FCFLAGS += $(FCFLAGS_PROFILING) endif ## OpenMP if FC_USE_OPENMP AM_FCFLAGS += $(FCFLAGS_OPENMP) endif ## MPI if FC_USE_MPI AM_FCFLAGS += $(FCFLAGS_MPI) endif if RECOLA_AVAILABLE AM_FCFLAGS += $(RECOLA_INCLUDES) endif ######################################################################## ## Non-standard targets and dependencies ## (Re)create F90 sources from NOWEB source. if NOWEB_AVAILABLE FILTER = -filter "sed 's/defn MPI:/defn/'" COMMON_SRC = \ $(COMMON_F90) PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw main.stamp: $(PRELUDE) $(srcdir)/main.nw $(POSTLUDE) @rm -f main.tmp @touch main.tmp for src in $(COMMON_SRC); do \ $(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \ done for src in $(MPI_F90:.f90_mpi=.f90); do \ $(NOTANGLE) -R[[$$src]] $(FILTER) $^ | $(CPIF) $$src'_mpi'; \ done for src in $(SERIAL_F90:.f90_serial=.f90); do \ $(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src'_serial'; \ done @mv -f main.tmp main.stamp $(MPI_F90) $(SERIAL_F90) $(COMMON_SRC): main.stamp ## Recover from the removal of $@ @if test -f $@; then :; else \ rm -f main.stamp; \ $(MAKE) $(AM_MAKEFLAGS) main.stamp; \ fi endif ######################################################################## ## Non-standard cleanup tasks ## Remove sources that can be recreated using NOWEB if NOWEB_AVAILABLE maintainer-clean-noweb: -rm -f *.f90 *.f90_mpi *.f90_serial *.c endif .PHONY: maintainer-clean-noweb ## Remove those sources also if builddir and srcdir are different if NOWEB_AVAILABLE clean-noweb: test "$(srcdir)" != "." && rm -f *.f90 *.f90_mpi *.f90_serial *.c || true endif .PHONY: clean-noweb ## Remove F90 module files clean-local: clean-noweb -rm -f main.stamp main.tmp -rm -f *.$(FCMOD) if FC_SUBMODULES -rm -f *.smod endif ## Remove backup files maintainer-clean-backup: -rm -f *~ .PHONY: maintainer-clean-backup ## Register additional clean targets maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup Index: trunk/src/beams/beams.nw =================================================================== --- trunk/src/beams/beams.nw (revision 8815) +++ trunk/src/beams/beams.nw (revision 8816) @@ -1,28230 +1,28230 @@ %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: beams and beam structure %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Beams} \includemodulegraph{beams} These modules implement beam configuration and beam structure, the latter in abstract terms. \begin{description} \item[beam\_structures] The [[beam_structure_t]] type is a messenger type that communicates the user settings to the \whizard\ core. \item[beams] Beam configuration. \item[sf\_aux] Tools for handling structure functions and splitting \item[sf\_mappings] Mapping functions, useful for structure function implementation \item[sf\_base] The abstract structure-function interaction and structure-function chain types. \end{description} These are the implementation modules, the concrete counterparts of [[sf_base]]: \begin{description} \item[sf\_isr] ISR structure function (photon radiation inclusive and resummed in collinear and IR regions). \item[sf\_epa] Effective Photon Approximation. \item[sf\_ewa] Effective $W$ (and $Z$) approximation. \item[sf\_escan] Energy spectrum that emulates a uniform energy scan. \item[sf\_gaussian] Gaussian beam spread \item[sf\_beam\_events] Beam-event generator that reads its input from an external file. \item[sf\_circe1] CIRCE1 beam spectra for electrons and photons. \item[sf\_circe2] CIRCE2 beam spectra for electrons and photons. \item[hoppet\_interface] Support for $b$-quark matching, addon to PDF modules. \item[sf\_pdf\_builtin] Direct support for selected hadron PDFs. \item[sf\_lhapdf] LHAPDF library support. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Beam structure} This module stores the beam structure definition as it is declared in the SINDARIN script. The structure definition is not analyzed, just recorded for later use. We do not capture any numerical parameters, just names of particles and structure functions. <<[[beam_structures.f90]]>>= <> module beam_structures <> <> use lorentz use polarizations <> <> <> <> interface <> end interface end module beam_structures @ %def beam_structures @ <<[[beam_structures_sub.f90]]>>= <> submodule (beam_structures) beam_structures_s use io_units use format_defs, only: FMT_19 use diagnostics implicit none contains <> end submodule beam_structures_s @ %def beam_structures_s @ \subsection{Beam structure elements} An entry in a beam-structure record consists of a string that denotes a type of structure function. <>= type :: beam_structure_entry_t logical :: is_valid = .false. type(string_t) :: name contains <> end type beam_structure_entry_t @ %def beam_structure_entry_t @ Output. <>= procedure :: to_string => beam_structure_entry_to_string <>= module function beam_structure_entry_to_string (object) result (string) class(beam_structure_entry_t), intent(in) :: object type(string_t) :: string end function beam_structure_entry_to_string <>= module function beam_structure_entry_to_string (object) result (string) class(beam_structure_entry_t), intent(in) :: object type(string_t) :: string if (object%is_valid) then string = object%name else string = "none" end if end function beam_structure_entry_to_string @ %def beam_structure_entry_to_string @ A record in the beam-structure sequence denotes either a structure-function entry, a pair of such entries, or a pair spectrum. <>= type :: beam_structure_record_t type(beam_structure_entry_t), dimension(:), allocatable :: entry end type beam_structure_record_t @ %def beam_structure_record_t @ \subsection{Beam structure type} The beam-structure object contains the beam particle(s) as simple strings. The sequence of records indicates the structure functions by name. No numerical parameters are stored. <>= public :: beam_structure_t <>= type :: beam_structure_t private integer :: n_beam = 0 type(string_t), dimension(:), allocatable :: prt type(beam_structure_record_t), dimension(:), allocatable :: record type(smatrix_t), dimension(:), allocatable :: smatrix real(default), dimension(:), allocatable :: pol_f real(default), dimension(:), allocatable :: p real(default), dimension(:), allocatable :: theta real(default), dimension(:), allocatable :: phi contains <> end type beam_structure_t @ %def beam_structure_t @ The finalizer deletes all contents explicitly, so we can continue with an empty beam record. (It is not needed for deallocation.) We have distinct finalizers for the independent parts of the beam structure. <>= procedure :: final_sf => beam_structure_final_sf <>= module subroutine beam_structure_final_sf (object) class(beam_structure_t), intent(inout) :: object end subroutine beam_structure_final_sf <>= module subroutine beam_structure_final_sf (object) class(beam_structure_t), intent(inout) :: object if (allocated (object%prt)) deallocate (object%prt) if (allocated (object%record)) deallocate (object%record) object%n_beam = 0 end subroutine beam_structure_final_sf @ %def beam_structure_final_sf @ Output. The actual information fits in a single line, therefore we can provide a [[to_string]] method. The [[show]] method also lists the current values of relevant global variables. <>= procedure :: write => beam_structure_write procedure :: to_string => beam_structure_to_string <>= module subroutine beam_structure_write (object, unit) class(beam_structure_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine beam_structure_write module function beam_structure_to_string (object, sf_only) result (string) class(beam_structure_t), intent(in) :: object logical, intent(in), optional :: sf_only type(string_t) :: string end function beam_structure_to_string <>= module subroutine beam_structure_write (object, unit) class(beam_structure_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1x,A,A)") "Beam structure: ", char (object%to_string ()) if (allocated (object%smatrix)) then do i = 1, size (object%smatrix) write (u, "(3x,A,I0,A)") "polarization (beam ", i, "):" call object%smatrix(i)%write (u, indent=2) end do end if if (allocated (object%pol_f)) then write (u, "(3x,A,F10.7,:,',',F10.7)") "polarization degree =", & object%pol_f end if if (allocated (object%p)) then write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // & ")") "momentum =", object%p end if if (allocated (object%theta)) then write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // & ")") "angle th =", object%theta end if if (allocated (object%phi)) then write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // & ")") "angle ph =", object%phi end if end subroutine beam_structure_write module function beam_structure_to_string (object, sf_only) result (string) class(beam_structure_t), intent(in) :: object logical, intent(in), optional :: sf_only type(string_t) :: string integer :: i, j logical :: with_beams with_beams = .true.; if (present (sf_only)) with_beams = .not. sf_only select case (object%n_beam) case (1) if (with_beams) then string = object%prt(1) else string = "" end if case (2) if (with_beams) then string = object%prt(1) // ", " // object%prt(2) else string = "" end if if (allocated (object%record)) then if (size (object%record) > 0) then if (with_beams) string = string // " => " do i = 1, size (object%record) if (i > 1) string = string // " => " do j = 1, size (object%record(i)%entry) if (j > 1) string = string // ", " string = string // object%record(i)%entry(j)%to_string () end do end do end if end if case default string = "[any particles]" end select end function beam_structure_to_string @ %def beam_structure_write beam_structure_to_string @ Initializer: dimension the beam structure record. Each array element denotes the number of entries for a record within the beam-structure sequence. The number of entries is either one or two, while the number of records is unlimited. <>= procedure :: init_sf => beam_structure_init_sf <>= module subroutine beam_structure_init_sf (beam_structure, prt, dim_array) class(beam_structure_t), intent(inout) :: beam_structure type(string_t), dimension(:), intent(in) :: prt integer, dimension(:), intent(in), optional :: dim_array end subroutine beam_structure_init_sf <>= module subroutine beam_structure_init_sf (beam_structure, prt, dim_array) class(beam_structure_t), intent(inout) :: beam_structure type(string_t), dimension(:), intent(in) :: prt integer, dimension(:), intent(in), optional :: dim_array integer :: i call beam_structure%final_sf () beam_structure%n_beam = size (prt) allocate (beam_structure%prt (size (prt))) beam_structure%prt = prt if (present (dim_array)) then allocate (beam_structure%record (size (dim_array))) do i = 1, size (dim_array) allocate (beam_structure%record(i)%entry (dim_array(i))) end do else allocate (beam_structure%record (0)) end if end subroutine beam_structure_init_sf @ %def beam_structure_init_sf @ Set an entry, specified by record number and entry number. <>= procedure :: set_sf => beam_structure_set_sf <>= module subroutine beam_structure_set_sf (beam_structure, i, j, name) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i, j type(string_t), intent(in) :: name end subroutine beam_structure_set_sf <>= module subroutine beam_structure_set_sf (beam_structure, i, j, name) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i, j type(string_t), intent(in) :: name associate (entry => beam_structure%record(i)%entry(j)) entry%name = name entry%is_valid = .true. end associate end subroutine beam_structure_set_sf @ %def beam_structure_set_sf @ Expand the beam-structure object. (i) For a pair spectrum, keep the entry. (ii) For a single-particle structure function written as a single entry, replace this by a record with two entries. (ii) For a record with two nontrivial entries, separate this into two records with one trivial entry each. To achieve this, we need a function that tells us whether an entry is a spectrum or a structure function. It returns 0 for a trivial entry, 1 for a single-particle structure function, and 2 for a two-particle spectrum. <>= abstract interface function strfun_mode_fun (name) result (n) import type(string_t), intent(in) :: name integer :: n end function strfun_mode_fun end interface @ %def is_spectrum_t @ Algorithm: (1) Mark entries as invalid where necessary. (2) Count the number of entries that we will need. (3) Expand and copy entries to a new record array. (4) Replace the old array by the new one. <>= procedure :: expand => beam_structure_expand <>= module subroutine beam_structure_expand (beam_structure, strfun_mode) class(beam_structure_t), intent(inout) :: beam_structure procedure(strfun_mode_fun) :: strfun_mode end subroutine beam_structure_expand <>= module subroutine beam_structure_expand (beam_structure, strfun_mode) class(beam_structure_t), intent(inout) :: beam_structure procedure(strfun_mode_fun) :: strfun_mode type(beam_structure_record_t), dimension(:), allocatable :: new integer :: n_record, i, j if (.not. allocated (beam_structure%record)) return do i = 1, size (beam_structure%record) associate (entry => beam_structure%record(i)%entry) do j = 1, size (entry) select case (strfun_mode (entry(j)%name)) case (0); entry(j)%is_valid = .false. end select end do end associate end do n_record = 0 do i = 1, size (beam_structure%record) associate (entry => beam_structure%record(i)%entry) select case (size (entry)) case (1) if (entry(1)%is_valid) then select case (strfun_mode (entry(1)%name)) case (1); n_record = n_record + 2 case (2); n_record = n_record + 1 end select end if case (2) do j = 1, 2 if (entry(j)%is_valid) then select case (strfun_mode (entry(j)%name)) case (1); n_record = n_record + 1 case (2) call beam_structure%write () call msg_fatal ("Pair spectrum used as & &single-particle structure function") end select end if end do end select end associate end do allocate (new (n_record)) n_record = 0 do i = 1, size (beam_structure%record) associate (entry => beam_structure%record(i)%entry) select case (size (entry)) case (1) if (entry(1)%is_valid) then select case (strfun_mode (entry(1)%name)) case (1) n_record = n_record + 1 allocate (new(n_record)%entry (2)) new(n_record)%entry(1) = entry(1) n_record = n_record + 1 allocate (new(n_record)%entry (2)) new(n_record)%entry(2) = entry(1) case (2) n_record = n_record + 1 allocate (new(n_record)%entry (1)) new(n_record)%entry(1) = entry(1) end select end if case (2) do j = 1, 2 if (entry(j)%is_valid) then n_record = n_record + 1 allocate (new(n_record)%entry (2)) new(n_record)%entry(j) = entry(j) end if end do end select end associate end do call move_alloc (from = new, to = beam_structure%record) end subroutine beam_structure_expand @ %def beam_structure_expand @ \subsection{Polarization} To record polarization, we provide an allocatable array of [[smatrix]] objects, sparse matrices. The polarization structure is independent of the structure-function setup, they are combined only when an actual beam object is constructed. <>= procedure :: final_pol => beam_structure_final_pol procedure :: init_pol => beam_structure_init_pol <>= module subroutine beam_structure_final_pol (beam_structure) class(beam_structure_t), intent(inout) :: beam_structure end subroutine beam_structure_final_pol module subroutine beam_structure_init_pol (beam_structure, n) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: n end subroutine beam_structure_init_pol <>= module subroutine beam_structure_final_pol (beam_structure) class(beam_structure_t), intent(inout) :: beam_structure if (allocated (beam_structure%smatrix)) deallocate (beam_structure%smatrix) if (allocated (beam_structure%pol_f)) deallocate (beam_structure%pol_f) end subroutine beam_structure_final_pol module subroutine beam_structure_init_pol (beam_structure, n) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: n if (allocated (beam_structure%smatrix)) deallocate (beam_structure%smatrix) allocate (beam_structure%smatrix (n)) if (.not. allocated (beam_structure%pol_f)) & allocate (beam_structure%pol_f (n), source = 1._default) end subroutine beam_structure_init_pol @ %def beam_structure_final_pol @ %def beam_structure_init_pol @ Check if polarized beams are used. <>= procedure :: has_polarized_beams => beam_structure_has_polarized_beams <>= elemental module function beam_structure_has_polarized_beams & (beam_structure) result (pol) logical :: pol class(beam_structure_t), intent(in) :: beam_structure end function beam_structure_has_polarized_beams <>= elemental module function beam_structure_has_polarized_beams & (beam_structure) result (pol) logical :: pol class(beam_structure_t), intent(in) :: beam_structure if (allocated (beam_structure%pol_f)) then pol = any (beam_structure%pol_f /= 0) else pol = .false. end if end function beam_structure_has_polarized_beams @ %def beam_structure_has_polarized_beams @ Directly copy the spin density matrices. <>= procedure :: set_smatrix => beam_structure_set_smatrix <>= module subroutine beam_structure_set_smatrix (beam_structure, i, smatrix) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i type(smatrix_t), intent(in) :: smatrix end subroutine beam_structure_set_smatrix <>= module subroutine beam_structure_set_smatrix (beam_structure, i, smatrix) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i type(smatrix_t), intent(in) :: smatrix beam_structure%smatrix(i) = smatrix end subroutine beam_structure_set_smatrix @ %def beam_structure_set_smatrix @ Initialize one of the spin density matrices manually. <>= procedure :: init_smatrix => beam_structure_init_smatrix <>= module subroutine beam_structure_init_smatrix (beam_structure, i, n_entry) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i integer, intent(in) :: n_entry end subroutine beam_structure_init_smatrix <>= module subroutine beam_structure_init_smatrix (beam_structure, i, n_entry) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i integer, intent(in) :: n_entry call beam_structure%smatrix(i)%init (2, n_entry) end subroutine beam_structure_init_smatrix @ %def beam_structure_init_smatrix @ Set a polarization entry. <>= procedure :: set_sentry => beam_structure_set_sentry <>= module subroutine beam_structure_set_sentry & (beam_structure, i, i_entry, index, value) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i integer, intent(in) :: i_entry integer, dimension(:), intent(in) :: index complex(default), intent(in) :: value end subroutine beam_structure_set_sentry <>= module subroutine beam_structure_set_sentry & (beam_structure, i, i_entry, index, value) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i integer, intent(in) :: i_entry integer, dimension(:), intent(in) :: index complex(default), intent(in) :: value call beam_structure%smatrix(i)%set_entry (i_entry, index, value) end subroutine beam_structure_set_sentry @ %def beam_structure_set_sentry @ Set the array of polarization fractions. <>= procedure :: set_pol_f => beam_structure_set_pol_f <>= module subroutine beam_structure_set_pol_f (beam_structure, f) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: f end subroutine beam_structure_set_pol_f <>= module subroutine beam_structure_set_pol_f (beam_structure, f) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: f if (allocated (beam_structure%pol_f)) deallocate (beam_structure%pol_f) allocate (beam_structure%pol_f (size (f)), source = f) end subroutine beam_structure_set_pol_f @ %def beam_structure_set_pol_f @ \subsection{Beam momenta} By default, beam momenta are deduced from the [[sqrts]] value or from the mass of the decaying particle, assuming a c.m.\ setup. Here we set them explicitly. <>= procedure :: final_mom => beam_structure_final_mom <>= module subroutine beam_structure_final_mom (beam_structure) class(beam_structure_t), intent(inout) :: beam_structure end subroutine beam_structure_final_mom <>= module subroutine beam_structure_final_mom (beam_structure) class(beam_structure_t), intent(inout) :: beam_structure if (allocated (beam_structure%p)) deallocate (beam_structure%p) if (allocated (beam_structure%theta)) deallocate (beam_structure%theta) if (allocated (beam_structure%phi)) deallocate (beam_structure%phi) end subroutine beam_structure_final_mom @ %def beam_structure_final_mom <>= procedure :: set_momentum => beam_structure_set_momentum procedure :: set_theta => beam_structure_set_theta procedure :: set_phi => beam_structure_set_phi <>= module subroutine beam_structure_set_momentum (beam_structure, p) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: p end subroutine beam_structure_set_momentum module subroutine beam_structure_set_theta (beam_structure, theta) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: theta end subroutine beam_structure_set_theta module subroutine beam_structure_set_phi (beam_structure, phi) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: phi end subroutine beam_structure_set_phi <>= module subroutine beam_structure_set_momentum (beam_structure, p) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: p if (allocated (beam_structure%p)) deallocate (beam_structure%p) allocate (beam_structure%p (size (p)), source = p) end subroutine beam_structure_set_momentum module subroutine beam_structure_set_theta (beam_structure, theta) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: theta if (allocated (beam_structure%theta)) deallocate (beam_structure%theta) allocate (beam_structure%theta (size (theta)), source = theta) end subroutine beam_structure_set_theta module subroutine beam_structure_set_phi (beam_structure, phi) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: phi if (allocated (beam_structure%phi)) deallocate (beam_structure%phi) allocate (beam_structure%phi (size (phi)), source = phi) end subroutine beam_structure_set_phi @ %def beam_structure_set_momentum @ %def beam_structure_set_theta @ %def beam_structure_set_phi @ \subsection{Get contents} Look at the incoming particles. We may also have the case that beam particles are not specified, but polarization. <>= procedure :: is_set => beam_structure_is_set procedure :: get_n_beam => beam_structure_get_n_beam procedure :: get_prt => beam_structure_get_prt <>= module function beam_structure_is_set (beam_structure) result (flag) class(beam_structure_t), intent(in) :: beam_structure logical :: flag end function beam_structure_is_set module function beam_structure_get_n_beam (beam_structure) result (n) class(beam_structure_t), intent(in) :: beam_structure integer :: n end function beam_structure_get_n_beam module function beam_structure_get_prt (beam_structure) result (prt) class(beam_structure_t), intent(in) :: beam_structure type(string_t), dimension(:), allocatable :: prt end function beam_structure_get_prt <>= module function beam_structure_is_set (beam_structure) result (flag) class(beam_structure_t), intent(in) :: beam_structure logical :: flag flag = beam_structure%n_beam > 0 .or. beam_structure%asymmetric () end function beam_structure_is_set module function beam_structure_get_n_beam (beam_structure) result (n) class(beam_structure_t), intent(in) :: beam_structure integer :: n n = beam_structure%n_beam end function beam_structure_get_n_beam module function beam_structure_get_prt (beam_structure) result (prt) class(beam_structure_t), intent(in) :: beam_structure type(string_t), dimension(:), allocatable :: prt allocate (prt (size (beam_structure%prt))) prt = beam_structure%prt end function beam_structure_get_prt @ %def beam_structure_is_set @ %def beam_structure_get_n_beam @ %def beam_structure_get_prt @ Return the number of records. <>= procedure :: get_n_record => beam_structure_get_n_record <>= module function beam_structure_get_n_record (beam_structure) result (n) class(beam_structure_t), intent(in) :: beam_structure integer :: n end function beam_structure_get_n_record <>= module function beam_structure_get_n_record (beam_structure) result (n) class(beam_structure_t), intent(in) :: beam_structure integer :: n if (allocated (beam_structure%record)) then n = size (beam_structure%record) else n = 0 end if end function beam_structure_get_n_record @ %def beam_structure_get_n_record @ Return an array consisting of the beam indices affected by the valid entries within a record. After expansion, there should be exactly one valid entry per record. <>= procedure :: get_i_entry => beam_structure_get_i_entry <>= module function beam_structure_get_i_entry & (beam_structure, i) result (i_entry) class(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: i integer, dimension(:), allocatable :: i_entry end function beam_structure_get_i_entry <>= module function beam_structure_get_i_entry & (beam_structure, i) result (i_entry) class(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: i integer, dimension(:), allocatable :: i_entry associate (record => beam_structure%record(i)) select case (size (record%entry)) case (1) if (record%entry(1)%is_valid) then allocate (i_entry (2), source = [1, 2]) else allocate (i_entry (0)) end if case (2) if (all (record%entry%is_valid)) then allocate (i_entry (2), source = [1, 2]) else if (record%entry(1)%is_valid) then allocate (i_entry (1), source = [1]) else if (record%entry(2)%is_valid) then allocate (i_entry (1), source = [2]) else allocate (i_entry (0)) end if end select end associate end function beam_structure_get_i_entry @ %def beam_structure_get_i_entry @ Return the name of the first valid entry within a record. After expansion, there should be exactly one valid entry per record. <>= procedure :: get_name => beam_structure_get_name <>= module function beam_structure_get_name (beam_structure, i) result (name) type(string_t) :: name class(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: i end function beam_structure_get_name <>= module function beam_structure_get_name (beam_structure, i) result (name) type(string_t) :: name class(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: i associate (record => beam_structure%record(i)) if (record%entry(1)%is_valid) then name = record%entry(1)%name else if (size (record%entry) == 2) then name = record%entry(2)%name end if end associate end function beam_structure_get_name @ %def beam_structure_get_name @ <>= procedure :: has_pdf => beam_structure_has_pdf <>= module function beam_structure_has_pdf (beam_structure) result (has_pdf) logical :: has_pdf class(beam_structure_t), intent(in) :: beam_structure end function beam_structure_has_pdf <>= module function beam_structure_has_pdf (beam_structure) result (has_pdf) logical :: has_pdf class(beam_structure_t), intent(in) :: beam_structure integer :: i type(string_t) :: name has_pdf = .false. do i = 1, beam_structure%get_n_record () name = beam_structure%get_name (i) has_pdf = has_pdf .or. name == var_str ("pdf_builtin") .or. name == var_str ("lhapdf") end do end function beam_structure_has_pdf @ %def beam_structure_has_pdf @ Return true if the beam structure contains a particular structure function identifier (such as [[lhapdf]], [[isr]], etc.) <>= procedure :: contains => beam_structure_contains <>= module function beam_structure_contains (beam_structure, name) result (flag) class(beam_structure_t), intent(in) :: beam_structure character(*), intent(in) :: name logical :: flag end function beam_structure_contains <>= module function beam_structure_contains (beam_structure, name) result (flag) class(beam_structure_t), intent(in) :: beam_structure character(*), intent(in) :: name logical :: flag integer :: i, j flag = .false. if (allocated (beam_structure%record)) then do i = 1, size (beam_structure%record) do j = 1, size (beam_structure%record(i)%entry) flag = beam_structure%record(i)%entry(j)%name == name if (flag) return end do end do end if end function beam_structure_contains @ %def beam_structure_contains @ Return polarization data. <>= procedure :: polarized => beam_structure_polarized procedure :: get_smatrix => beam_structure_get_smatrix procedure :: get_pol_f => beam_structure_get_pol_f procedure :: asymmetric => beam_structure_asymmetric <>= module function beam_structure_polarized (beam_structure) result (flag) class(beam_structure_t), intent(in) :: beam_structure logical :: flag end function beam_structure_polarized module function beam_structure_get_smatrix (beam_structure) result (smatrix) class(beam_structure_t), intent(in) :: beam_structure type(smatrix_t), dimension(:), allocatable :: smatrix end function beam_structure_get_smatrix module function beam_structure_get_pol_f (beam_structure) result (pol_f) class(beam_structure_t), intent(in) :: beam_structure real(default), dimension(:), allocatable :: pol_f end function beam_structure_get_pol_f module function beam_structure_asymmetric (beam_structure) result (flag) class(beam_structure_t), intent(in) :: beam_structure logical :: flag end function beam_structure_asymmetric <>= module function beam_structure_polarized (beam_structure) result (flag) class(beam_structure_t), intent(in) :: beam_structure logical :: flag flag = allocated (beam_structure%smatrix) end function beam_structure_polarized module function beam_structure_get_smatrix (beam_structure) result (smatrix) class(beam_structure_t), intent(in) :: beam_structure type(smatrix_t), dimension(:), allocatable :: smatrix allocate (smatrix (size (beam_structure%smatrix)), & source = beam_structure%smatrix) end function beam_structure_get_smatrix module function beam_structure_get_pol_f (beam_structure) result (pol_f) class(beam_structure_t), intent(in) :: beam_structure real(default), dimension(:), allocatable :: pol_f allocate (pol_f (size (beam_structure%pol_f)), & source = beam_structure%pol_f) end function beam_structure_get_pol_f module function beam_structure_asymmetric (beam_structure) result (flag) class(beam_structure_t), intent(in) :: beam_structure logical :: flag flag = allocated (beam_structure%p) & .or. allocated (beam_structure%theta) & .or. allocated (beam_structure%phi) end function beam_structure_asymmetric @ %def beam_structure_polarized @ %def beam_structure_get_smatrix @ %def beam_structure_get_pol_f @ %def beam_structure_asymmetric @ Return the beam momenta (the space part, i.e., three-momenta). This is meaningful only if momenta and, optionally, angles have been set. <>= procedure :: get_momenta => beam_structure_get_momenta <>= module function beam_structure_get_momenta (beam_structure) result (p) class(beam_structure_t), intent(in) :: beam_structure type(vector3_t), dimension(:), allocatable :: p end function beam_structure_get_momenta <>= module function beam_structure_get_momenta (beam_structure) result (p) class(beam_structure_t), intent(in) :: beam_structure type(vector3_t), dimension(:), allocatable :: p real(default), dimension(:), allocatable :: theta, phi integer :: n, i if (allocated (beam_structure%p)) then n = size (beam_structure%p) if (allocated (beam_structure%theta)) then if (size (beam_structure%theta) == n) then allocate (theta (n), source = beam_structure%theta) else call msg_fatal ("Beam structure: mismatch in momentum vs. & &angle theta specification") end if else allocate (theta (n), source = 0._default) end if if (allocated (beam_structure%phi)) then if (size (beam_structure%phi) == n) then allocate (phi (n), source = beam_structure%phi) else call msg_fatal ("Beam structure: mismatch in momentum vs. & &angle phi specification") end if else allocate (phi (n), source = 0._default) end if allocate (p (n)) do i = 1, n p(i) = beam_structure%p(i) * vector3_moving ([ & sin (theta(i)) * cos (phi(i)), & sin (theta(i)) * sin (phi(i)), & cos (theta(i))]) end do if (n == 2) p(2) = - p(2) else call msg_fatal ("Beam structure: angle theta/phi specified but & &momentum/a p undefined") end if end function beam_structure_get_momenta @ %def beam_structure_get_momenta @ Check for a complete beam structure. The [[applies]] flag tells if the beam structure should actually be used for a process with the given [[n_in]] number of incoming particles. It set if the beam structure matches the process as either decay or scattering. It is unset if beam structure references a scattering setup but the process is a decay. It is also unset if the beam structure itself is empty. If the beam structure cannot be used, terminate with fatal error. <>= procedure :: check_against_n_in => beam_structure_check_against_n_in <>= module subroutine beam_structure_check_against_n_in & (beam_structure, n_in, applies) class(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: n_in logical, intent(out) :: applies end subroutine beam_structure_check_against_n_in <>= module subroutine beam_structure_check_against_n_in & (beam_structure, n_in, applies) class(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: n_in logical, intent(out) :: applies if (beam_structure%is_set ()) then if (n_in == beam_structure%get_n_beam ()) then applies = .true. else if (beam_structure%get_n_beam () == 0) then call msg_fatal & ("Asymmetric beams: missing beam particle specification") applies = .false. else call msg_fatal & ("Mismatch of process and beam setup (scattering/decay)") applies = .false. end if else applies = .false. end if end subroutine beam_structure_check_against_n_in @ %def beam_structure_check_against_n_in @ \subsection{Unit Tests} Test module, followed by the corresponding implementation module. <<[[beam_structures_ut.f90]]>>= <> module beam_structures_ut use unit_tests use beam_structures_uti <> <> contains <> end module beam_structures_ut @ %def beam_structures_ut @ <<[[beam_structures_uti.f90]]>>= <> module beam_structures_uti <> <> use beam_structures <> <> contains <> <> end module beam_structures_uti @ %def beam_structures_ut @ API: driver for the unit tests below. <>= public :: beam_structures_test <>= subroutine beam_structures_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine beam_structures_test @ %def beam_structures_tests @ \subsubsection{Empty structure} <>= call test (beam_structures_1, "beam_structures_1", & "empty beam structure record", & u, results) <>= public :: beam_structures_1 <>= subroutine beam_structures_1 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure write (u, "(A)") "* Test output: beam_structures_1" write (u, "(A)") "* Purpose: display empty beam structure record" write (u, "(A)") call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_1" end subroutine beam_structures_1 @ %def beam_structures_1 @ \subsubsection{Nontrivial configurations} <>= call test (beam_structures_2, "beam_structures_2", & "beam structure records", & u, results) <>= public :: beam_structures_2 <>= subroutine beam_structures_2 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure integer, dimension(0) :: empty_array type(string_t) :: s write (u, "(A)") "* Test output: beam_structures_2" write (u, "(A)") "* Purpose: setup beam structure records" write (u, "(A)") s = "s" call beam_structure%init_sf ([s], empty_array) call beam_structure%write (u) write (u, "(A)") call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%write (u) write (u, "(A)") call beam_structure%init_sf ([s, s], [2]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%set_sf (1, 2, var_str ("b")) call beam_structure%write (u) write (u, "(A)") call beam_structure%init_sf ([s, s], [2, 1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%set_sf (1, 2, var_str ("b")) call beam_structure%set_sf (2, 1, var_str ("c")) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_2" end subroutine beam_structures_2 @ %def beam_structures_2 @ \subsubsection{Expansion} Provide a function that tells, for the dummy structure function names used here, whether they are considered a two-particle spectrum or a single-particle structure function: <>= function test_strfun_mode (name) result (n) type(string_t), intent(in) :: name integer :: n select case (char (name)) case ("a"); n = 2 case ("b"); n = 1 case default; n = 0 end select end function test_strfun_mode @ %def test_ist_pair_spectrum @ <>= call test (beam_structures_3, "beam_structures_3", & "beam structure expansion", & u, results) <>= public :: beam_structures_3 <>= subroutine beam_structures_3 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure type(string_t) :: s write (u, "(A)") "* Test output: beam_structures_3" write (u, "(A)") "* Purpose: expand beam structure records" write (u, "(A)") s = "s" write (u, "(A)") "* Pair spectrum (keep as-is)" write (u, "(A)") call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%write (u) write (u, "(A)") call beam_structure%expand (test_strfun_mode) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Structure function pair (expand)" write (u, "(A)") call beam_structure%init_sf ([s, s], [2]) call beam_structure%set_sf (1, 1, var_str ("b")) call beam_structure%set_sf (1, 2, var_str ("b")) call beam_structure%write (u) write (u, "(A)") call beam_structure%expand (test_strfun_mode) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Structure function (separate and expand)" write (u, "(A)") call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_sf (1, 1, var_str ("b")) call beam_structure%write (u) write (u, "(A)") call beam_structure%expand (test_strfun_mode) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Combination" write (u, "(A)") call beam_structure%init_sf ([s, s], [1, 1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%set_sf (2, 1, var_str ("b")) call beam_structure%write (u) write (u, "(A)") call beam_structure%expand (test_strfun_mode) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_3" end subroutine beam_structures_3 @ %def beam_structures_3 @ \subsubsection{Public methods} Check the methods that can be called to get the beam-structure contents. <>= call test (beam_structures_4, "beam_structures_4", & "beam structure contents", & u, results) <>= public :: beam_structures_4 <>= subroutine beam_structures_4 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure type(string_t) :: s type(string_t), dimension(2) :: prt integer :: i write (u, "(A)") "* Test output: beam_structures_4" write (u, "(A)") "* Purpose: check the API" write (u, "(A)") s = "s" write (u, "(A)") "* Structure-function combination" write (u, "(A)") call beam_structure%init_sf ([s, s], [1, 2, 2]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%set_sf (2, 1, var_str ("b")) call beam_structure%set_sf (3, 2, var_str ("c")) call beam_structure%write (u) write (u, *) write (u, "(1x,A,I0)") "n_beam = ", beam_structure%get_n_beam () prt = beam_structure%get_prt () write (u, "(1x,A,2(1x,A))") "prt =", char (prt(1)), char (prt(2)) write (u, *) write (u, "(1x,A,I0)") "n_record = ", beam_structure%get_n_record () do i = 1, 3 write (u, "(A)") write (u, "(1x,A,I0,A,A)") "name(", i, ") = ", & char (beam_structure%get_name (i)) write (u, "(1x,A,I0,A,2(1x,I0))") "i_entry(", i, ") =", & beam_structure%get_i_entry (i) end do write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_4" end subroutine beam_structures_4 @ %def beam_structures_4 @ \subsubsection{Polarization} The polarization properties are independent from the structure-function setup. <>= call test (beam_structures_5, "beam_structures_5", & "polarization", & u, results) <>= public :: beam_structures_5 <>= subroutine beam_structures_5 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure integer, dimension(0) :: empty_array type(string_t) :: s write (u, "(A)") "* Test output: beam_structures_5" write (u, "(A)") "* Purpose: setup polarization in beam structure records" write (u, "(A)") s = "s" call beam_structure%init_sf ([s], empty_array) call beam_structure%init_pol (1) call beam_structure%init_smatrix (1, 1) call beam_structure%set_sentry (1, 1, [0,0], (1._default, 0._default)) call beam_structure%set_pol_f ([0.5_default]) call beam_structure%write (u) write (u, "(A)") call beam_structure%final_sf () call beam_structure%final_pol () call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%init_pol (2) call beam_structure%init_smatrix (1, 2) call beam_structure%set_sentry (1, 1, [-1,1], (0.5_default,-0.5_default)) call beam_structure%set_sentry (1, 2, [ 1,1], (1._default, 0._default)) call beam_structure%init_smatrix (2, 0) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_5" end subroutine beam_structures_5 @ %def beam_structures_5 @ \subsubsection{Momenta} The momenta are independent from the structure-function setup. <>= call test (beam_structures_6, "beam_structures_6", & "momenta", & u, results) <>= public :: beam_structures_6 <>= subroutine beam_structures_6 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure integer, dimension(0) :: empty_array type(string_t) :: s write (u, "(A)") "* Test output: beam_structures_6" write (u, "(A)") "* Purpose: setup momenta in beam structure records" write (u, "(A)") s = "s" call beam_structure%init_sf ([s], empty_array) call beam_structure%set_momentum ([500._default]) call beam_structure%write (u) write (u, "(A)") call beam_structure%final_sf () call beam_structure%final_mom () call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_momentum ([500._default, 700._default]) call beam_structure%set_theta ([0._default, 0.1_default]) call beam_structure%set_phi ([0._default, 1.51_default]) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_6" end subroutine beam_structures_6 @ %def beam_structures_6 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Beams for collisions and decays} <<[[beams.f90]]>>= <> module beams <> <> use lorentz use model_data use flavors use quantum_numbers use state_matrices use interactions use polarizations use beam_structures <> <> <> <> interface <> end interface end module beams @ %def beams @ <<[[beams_sub.f90]]>>= <> submodule (beams) beams_s use io_units use format_defs, only: FMT_19 use numeric_utils use diagnostics use md5 implicit none contains <> end submodule beams_s @ %def beams_s @ \subsection{Beam data} The beam data type contains beam data for one or two beams, depending on whether we are dealing with beam collisions or particle decay. In addition, it holds the c.m.\ energy [[sqrts]], the Lorentz transformation [[L]] that transforms the c.m.\ system into the lab system, and the pair of c.m.\ momenta. <>= public :: beam_data_t <>= type :: beam_data_t logical :: initialized = .false. integer :: n = 0 type(flavor_t), dimension(:), allocatable :: flv real(default), dimension(:), allocatable :: mass type(pmatrix_t), dimension(:), allocatable :: pmatrix logical :: lab_is_cm = .true. type(vector4_t), dimension(:), allocatable :: p_cm type(vector4_t), dimension(:), allocatable :: p type(lorentz_transformation_t), allocatable :: L_cm_to_lab real(default) :: sqrts = 0 character(32) :: md5sum = "" contains <> end type beam_data_t @ %def beam_data_t @ Generic initializer. This is called by the specific initializers below. Initialize either for decay or for collision. <>= subroutine beam_data_init (beam_data, n) type(beam_data_t), intent(out) :: beam_data integer, intent(in) :: n beam_data%n = n allocate (beam_data%flv (n)) allocate (beam_data%mass (n)) allocate (beam_data%pmatrix (n)) allocate (beam_data%p_cm (n)) allocate (beam_data%p (n)) beam_data%initialized = .true. end subroutine beam_data_init @ %def beam_data_init @ Finalizer: needed for the polarization components of the beams. <>= procedure :: final => beam_data_final <>= module subroutine beam_data_final (beam_data) class(beam_data_t), intent(inout) :: beam_data end subroutine beam_data_final <>= module subroutine beam_data_final (beam_data) class(beam_data_t), intent(inout) :: beam_data beam_data%initialized = .false. end subroutine beam_data_final @ %def beam_data_final @ The verbose (default) version is for debugging. The short version is for screen output in the UI. <>= procedure :: write => beam_data_write <>= module subroutine beam_data_write (beam_data, unit, verbose, write_md5sum) class(beam_data_t), intent(in) :: beam_data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, write_md5sum end subroutine beam_data_write <>= module subroutine beam_data_write (beam_data, unit, verbose, write_md5sum) class(beam_data_t), intent(in) :: beam_data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, write_md5sum integer :: prt_name_len logical :: verb, write_md5 integer :: u u = given_output_unit (unit); if (u < 0) return verb = .false.; if (present (verbose)) verb = verbose write_md5 = verb; if (present (write_md5sum)) write_md5 = write_md5sum if (.not. beam_data%initialized) then write (u, "(1x,A)") "Beam data: [undefined]" return end if prt_name_len = maxval (len (beam_data%flv%get_name ())) select case (beam_data%n) case (1) write (u, "(1x,A)") "Beam data (decay):" if (verb) then call write_prt (1) call beam_data%pmatrix(1)%write (u) write (u, *) "R.f. momentum:" call vector4_write (beam_data%p_cm(1), u) write (u, *) "Lab momentum:" call vector4_write (beam_data%p(1), u) else call write_prt (1) end if case (2) write (u, "(1x,A)") "Beam data (collision):" if (verb) then call write_prt (1) call beam_data%pmatrix(1)%write (u) call write_prt (2) call beam_data%pmatrix(2)%write (u) call write_sqrts write (u, *) "C.m. momenta:" call vector4_write (beam_data%p_cm(1), u) call vector4_write (beam_data%p_cm(2), u) write (u, *) "Lab momenta:" call vector4_write (beam_data%p(1), u) call vector4_write (beam_data%p(2), u) else call write_prt (1) call write_prt (2) call write_sqrts end if end select if (allocated (beam_data%L_cm_to_lab)) then if (verb) then call lorentz_transformation_write (beam_data%L_cm_to_lab, u) else write (u, "(1x,A)") "Beam structure: lab and c.m. frame differ" end if end if if (write_md5) then write (u, *) "MD5 sum: ", beam_data%md5sum end if contains subroutine write_sqrts character(80) :: sqrts_str write (sqrts_str, "(" // FMT_19 // ")") beam_data%sqrts write (u, "(3x,A)") "sqrts = " // trim (adjustl (sqrts_str)) // " GeV" end subroutine write_sqrts subroutine write_prt (i) integer, intent(in) :: i character(80) :: name_str, mass_str write (name_str, "(A)") char (beam_data%flv(i)%get_name ()) write (mass_str, "(ES13.7)") beam_data%mass(i) write (u, "(3x,A)", advance="no") & name_str(:prt_name_len) // " (mass = " & // trim (adjustl (mass_str)) // " GeV)" if (beam_data%pmatrix(i)%is_polarized ()) then write (u, "(2x,A)") "polarized" else write (u, *) end if end subroutine write_prt end subroutine beam_data_write @ %def beam_data_write @ Return initialization status: <>= procedure :: are_valid => beam_data_are_valid <>= module function beam_data_are_valid (beam_data) result (flag) class(beam_data_t), intent(in) :: beam_data logical :: flag end function beam_data_are_valid <>= module function beam_data_are_valid (beam_data) result (flag) class(beam_data_t), intent(in) :: beam_data logical :: flag flag = beam_data%initialized end function beam_data_are_valid @ %def beam_data_are_valid @ Check whether beam data agree with the current values of relevant parameters. <>= procedure :: check_scattering => beam_data_check_scattering <>= module subroutine beam_data_check_scattering (beam_data, sqrts) class(beam_data_t), intent(in) :: beam_data real(default), intent(in), optional :: sqrts end subroutine beam_data_check_scattering <>= module subroutine beam_data_check_scattering (beam_data, sqrts) class(beam_data_t), intent(in) :: beam_data real(default), intent(in), optional :: sqrts if (beam_data_are_valid (beam_data)) then if (present (sqrts)) then if (.not. nearly_equal (sqrts, beam_data%sqrts)) then call msg_error ("Current setting of sqrts is inconsistent " & // "with beam setup (ignored).") end if end if else call msg_bug ("Beam setup: invalid beam data") end if end subroutine beam_data_check_scattering @ %def beam_data_check_scattering @ Return the number of beams (1 for decays, 2 for collisions). <>= procedure :: get_n_in => beam_data_get_n_in <>= module function beam_data_get_n_in (beam_data) result (n_in) class(beam_data_t), intent(in) :: beam_data integer :: n_in end function beam_data_get_n_in <>= module function beam_data_get_n_in (beam_data) result (n_in) class(beam_data_t), intent(in) :: beam_data integer :: n_in n_in = beam_data%n end function beam_data_get_n_in @ %def beam_data_get_n_in @ Return the beam flavor <>= procedure :: get_flavor => beam_data_get_flavor <>= module function beam_data_get_flavor (beam_data) result (flv) class(beam_data_t), intent(in) :: beam_data type(flavor_t), dimension(:), allocatable :: flv end function beam_data_get_flavor <>= module function beam_data_get_flavor (beam_data) result (flv) class(beam_data_t), intent(in) :: beam_data type(flavor_t), dimension(:), allocatable :: flv allocate (flv (beam_data%n)) flv = beam_data%flv end function beam_data_get_flavor @ %def beam_data_get_flavor @ Return the beam energies <>= procedure :: get_energy => beam_data_get_energy <>= module function beam_data_get_energy (beam_data) result (e) class(beam_data_t), intent(in) :: beam_data real(default), dimension(:), allocatable :: e end function beam_data_get_energy <>= module function beam_data_get_energy (beam_data) result (e) class(beam_data_t), intent(in) :: beam_data real(default), dimension(:), allocatable :: e integer :: i allocate (e (beam_data%n)) if (beam_data%initialized) then do i = 1, beam_data%n e(i) = energy (beam_data%p(i)) end do else e = 0 end if end function beam_data_get_energy @ %def beam_data_get_energy @ Return the c.m.\ energy. <>= procedure :: get_sqrts => beam_data_get_sqrts <>= module function beam_data_get_sqrts (beam_data) result (sqrts) class(beam_data_t), intent(in) :: beam_data real(default) :: sqrts end function beam_data_get_sqrts <>= module function beam_data_get_sqrts (beam_data) result (sqrts) class(beam_data_t), intent(in) :: beam_data real(default) :: sqrts sqrts = beam_data%sqrts end function beam_data_get_sqrts @ %def beam_data_get_sqrts @ Return the polarization in case it is just two degrees <>= procedure :: get_polarization => beam_data_get_polarization <>= module function beam_data_get_polarization (beam_data) result (pol) class(beam_data_t), intent(in) :: beam_data real(default), dimension(beam_data%n) :: pol end function beam_data_get_polarization <>= module function beam_data_get_polarization (beam_data) result (pol) class(beam_data_t), intent(in) :: beam_data real(default), dimension(beam_data%n) :: pol pol = beam_data%pmatrix%get_simple_pol () end function beam_data_get_polarization @ %def beam_data_get_polarization @ <>= procedure :: get_helicity_state_matrix => beam_data_get_helicity_state_matrix <>= module function beam_data_get_helicity_state_matrix & (beam_data) result (state_hel) type(state_matrix_t) :: state_hel class(beam_data_t), intent(in) :: beam_data end function beam_data_get_helicity_state_matrix <>= module function beam_data_get_helicity_state_matrix & (beam_data) result (state_hel) type(state_matrix_t) :: state_hel class(beam_data_t), intent(in) :: beam_data type(polarization_t), dimension(:), allocatable :: pol integer :: i allocate (pol (beam_data%n)) do i = 1, beam_data%n call pol(i)%init_pmatrix (beam_data%pmatrix(i)) end do call combine_polarization_states (pol, state_hel) end function beam_data_get_helicity_state_matrix @ %def beam_data_get_helicity_state_matrix @ <>= procedure :: is_initialized => beam_data_is_initialized <>= module function beam_data_is_initialized (beam_data) result (initialized) logical :: initialized class(beam_data_t), intent(in) :: beam_data end function beam_data_is_initialized <>= module function beam_data_is_initialized (beam_data) result (initialized) logical :: initialized class(beam_data_t), intent(in) :: beam_data initialized = any (beam_data%pmatrix%exists ()) end function beam_data_is_initialized @ %def beam_data_is_initialized @ Return a MD5 checksum for beam data. If no checksum is present (because beams have not been initialized), compute the checksum of the sqrts value. <>= procedure :: get_md5sum => beam_data_get_md5sum <>= module function beam_data_get_md5sum & (beam_data, sqrts) result (md5sum_beams) class(beam_data_t), intent(in) :: beam_data real(default), intent(in) :: sqrts character(32) :: md5sum_beams end function beam_data_get_md5sum <>= module function beam_data_get_md5sum & (beam_data, sqrts) result (md5sum_beams) class(beam_data_t), intent(in) :: beam_data real(default), intent(in) :: sqrts character(32) :: md5sum_beams character(80) :: buffer if (beam_data%md5sum /= "") then md5sum_beams = beam_data%md5sum else write (buffer, *) sqrts md5sum_beams = md5sum (buffer) end if end function beam_data_get_md5sum @ %def beam_data_get_md5sum @ \subsection{Initializers: beam structure} Initialize the beam data object from a beam structure object, given energy and model. <>= procedure :: init_structure => beam_data_init_structure <>= module subroutine beam_data_init_structure & (beam_data, structure, sqrts, model, decay_rest_frame) class(beam_data_t), intent(out) :: beam_data type(beam_structure_t), intent(in) :: structure real(default), intent(in) :: sqrts class(model_data_t), intent(in), target :: model logical, intent(in), optional :: decay_rest_frame end subroutine beam_data_init_structure <>= module subroutine beam_data_init_structure & (beam_data, structure, sqrts, model, decay_rest_frame) class(beam_data_t), intent(out) :: beam_data type(beam_structure_t), intent(in) :: structure integer :: n_beam real(default), intent(in) :: sqrts class(model_data_t), intent(in), target :: model logical, intent(in), optional :: decay_rest_frame type(flavor_t), dimension(:), allocatable :: flv n_beam = structure%get_n_beam () allocate (flv (n_beam)) call flv%init (structure%get_prt (), model) if (structure%asymmetric ()) then if (structure%polarized ()) then call beam_data%init_momenta (structure%get_momenta (), flv, & structure%get_smatrix (), structure%get_pol_f ()) else call beam_data%init_momenta (structure%get_momenta (), flv) end if else select case (n_beam) case (1) if (structure%polarized ()) then call beam_data%init_decay (flv, & structure%get_smatrix (), structure%get_pol_f (), & rest_frame = decay_rest_frame) else call beam_data%init_decay (flv, & rest_frame = decay_rest_frame) end if case (2) if (structure%polarized ()) then call beam_data%init_sqrts (sqrts, flv, & structure%get_smatrix (), structure%get_pol_f ()) else call beam_data%init_sqrts (sqrts, flv) end if case default call msg_bug ("Beam data: invalid beam structure object") end select end if end subroutine beam_data_init_structure @ %def beam_data_init_structure @ \subsection{Initializers: collisions} This is the simplest one: just the two flavors, c.m.\ energy, polarization. Color is inferred from flavor. Beam momenta and c.m.\ momenta coincide. <>= procedure :: init_sqrts => beam_data_init_sqrts <>= module subroutine beam_data_init_sqrts & (beam_data, sqrts, flv, smatrix, pol_f) class(beam_data_t), intent(out) :: beam_data real(default), intent(in) :: sqrts type(flavor_t), dimension(:), intent(in) :: flv type(smatrix_t), dimension(:), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f end subroutine beam_data_init_sqrts <>= module subroutine beam_data_init_sqrts & (beam_data, sqrts, flv, smatrix, pol_f) class(beam_data_t), intent(out) :: beam_data real(default), intent(in) :: sqrts type(flavor_t), dimension(:), intent(in) :: flv type(smatrix_t), dimension(:), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f real(default), dimension(size(flv)) :: E, p call beam_data_init (beam_data, size (flv)) beam_data%sqrts = sqrts beam_data%lab_is_cm = .true. select case (beam_data%n) case (1) E = sqrts; p = 0 beam_data%p_cm = vector4_moving (E, p, 3) beam_data%p = beam_data%p_cm case (2) beam_data%p_cm = colliding_momenta (sqrts, flv%get_mass ()) beam_data%p = colliding_momenta (sqrts, flv%get_mass ()) end select call beam_data_finish_initialization (beam_data, flv, smatrix, pol_f) end subroutine beam_data_init_sqrts @ %def beam_data_init_sqrts @ This version sets beam momenta directly, assuming that they are asymmetric, i.e., lab frame and c.m.\ frame do not coincide. Polarization info is deferred to a common initializer. The Lorentz transformation that we compute here is not actually used in the calculation; instead, it will be recomputed for each event in the subroutine [[phs_set_incoming_momenta]]. We compute it here for the nominal beam setup nevertheless, so we can print it and, in particular, include it in the MD5 sum. <>= procedure :: init_momenta => beam_data_init_momenta <>= module subroutine beam_data_init_momenta & (beam_data, p3, flv, smatrix, pol_f) class(beam_data_t), intent(out) :: beam_data type(vector3_t), dimension(:), intent(in) :: p3 type(flavor_t), dimension(:), intent(in) :: flv type(smatrix_t), dimension(:), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f end subroutine beam_data_init_momenta <>= module subroutine beam_data_init_momenta & (beam_data, p3, flv, smatrix, pol_f) class(beam_data_t), intent(out) :: beam_data type(vector3_t), dimension(:), intent(in) :: p3 type(flavor_t), dimension(:), intent(in) :: flv type(smatrix_t), dimension(:), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f type(vector4_t) :: p0 type(vector4_t), dimension(:), allocatable :: p, p_cm_rot real(default), dimension(size(p3)) :: e real(default), dimension(size(flv)) :: m type(lorentz_transformation_t) :: L_boost, L_rot call beam_data_init (beam_data, size (flv)) m = flv%get_mass () e = sqrt (p3 ** 2 + m ** 2) allocate (p (beam_data%n)) p = vector4_moving (e, p3) p0 = sum (p) beam_data%p = p beam_data%lab_is_cm = .false. beam_data%sqrts = p0 ** 1 L_boost = boost (p0, beam_data%sqrts) allocate (p_cm_rot (beam_data%n)) p_cm_rot = inverse (L_boost) * p allocate (beam_data%L_cm_to_lab) select case (beam_data%n) case (1) beam_data%L_cm_to_lab = L_boost beam_data%p_cm = vector4_at_rest (beam_data%sqrts) case (2) L_rot = rotation_to_2nd (3, space_part (p_cm_rot(1))) beam_data%L_cm_to_lab = L_boost * L_rot beam_data%p_cm = & colliding_momenta (beam_data%sqrts, flv%get_mass ()) end select call beam_data_finish_initialization (beam_data, flv, smatrix, pol_f) end subroutine beam_data_init_momenta @ %def beam_data_init_momenta @ Final steps: If requested, rotate the beams in the lab frame, and set the beam-data components. <>= subroutine beam_data_finish_initialization (beam_data, flv, smatrix, pol_f) type(beam_data_t), intent(inout) :: beam_data type(flavor_t), dimension(:), intent(in) :: flv type(smatrix_t), dimension(:), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f integer :: i do i = 1, beam_data%n beam_data%flv(i) = flv(i) beam_data%mass(i) = flv(i)%get_mass () if (present (smatrix)) then if (size (smatrix) /= beam_data%n) & call msg_fatal ("Beam data: & &polarization density array has wrong dimension") beam_data%pmatrix(i) = smatrix(i) if (present (pol_f)) then if (size (pol_f) /= size (smatrix)) & call msg_fatal ("Beam data: & &polarization fraction array has wrong dimension") call beam_data%pmatrix(i)%normalize (flv(i), pol_f(i)) else call beam_data%pmatrix(i)%normalize (flv(i), 1._default) end if else call beam_data%pmatrix(i)%init (2, 0) call beam_data%pmatrix(i)%normalize (flv(i), 0._default) end if end do call beam_data%compute_md5sum () end subroutine beam_data_finish_initialization @ %def beam_data_finish_initialization @ The MD5 sum is stored within the beam-data record, so it can be checked for integrity in subsequent runs. <>= procedure :: compute_md5sum => beam_data_compute_md5sum <>= module subroutine beam_data_compute_md5sum (beam_data) class(beam_data_t), intent(inout) :: beam_data integer :: unit end subroutine beam_data_compute_md5sum <>= module subroutine beam_data_compute_md5sum (beam_data) class(beam_data_t), intent(inout) :: beam_data integer :: unit unit = free_unit () open (unit = unit, status = "scratch", action = "readwrite") call beam_data%write (unit, write_md5sum = .false., & verbose = .true.) rewind (unit) beam_data%md5sum = md5sum (unit) close (unit) end subroutine beam_data_compute_md5sum @ %def beam_data_compute_md5sum @ \subsection{Initializers: decays} This is the simplest one: decay in rest frame. We need just flavor and polarization. Color is inferred from flavor. Beam momentum and c.m.\ momentum coincide. <>= procedure :: init_decay => beam_data_init_decay <>= module subroutine beam_data_init_decay & (beam_data, flv, smatrix, pol_f, rest_frame) class(beam_data_t), intent(out) :: beam_data type(flavor_t), dimension(1), intent(in) :: flv type(smatrix_t), dimension(1), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f logical, intent(in), optional :: rest_frame end subroutine beam_data_init_decay <>= module subroutine beam_data_init_decay & (beam_data, flv, smatrix, pol_f, rest_frame) class(beam_data_t), intent(out) :: beam_data type(flavor_t), dimension(1), intent(in) :: flv type(smatrix_t), dimension(1), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f logical, intent(in), optional :: rest_frame real(default), dimension(1) :: m m = flv%get_mass () if (present (smatrix)) then call beam_data%init_sqrts (m(1), flv, smatrix, pol_f) else call beam_data%init_sqrts (m(1), flv, smatrix, pol_f) end if if (present (rest_frame)) beam_data%lab_is_cm = rest_frame end subroutine beam_data_init_decay @ %def beam_data_init_decay @ \subsection{The beams type} Beam objects are interaction objects that contain the actual beam data including polarization and density matrix. For collisions, the beam object actually contains two beams. <>= public :: beam_t <>= type :: beam_t private type(interaction_t) :: int end type beam_t @ %def beam_t @ The constructor contains code that converts beam data into the (entangled) particle-pair quantum state. First, we set the number of particles and polarization mask. (The polarization mask is handed over to all later interactions, so if helicity is diagonal or absent, this fact is used when constructing the hard-interaction events.) Then, we construct the entangled state that combines helicity, flavor and color of the two particles (where flavor and color are unique, while several helicity states are possible). Then, we transfer this state together with the associated values from the spin density matrix into the [[interaction_t]] object. Calling the [[add_state]] method of the interaction object, we keep the entries of the helicity density matrix without adding them up. This ensures that for unpolarized states, we do not normalize but end up with an $1/N$ entry, where $N$ is the initial-state multiplicity. <>= public :: beam_init <>= module subroutine beam_init (beam, beam_data) type(beam_t), intent(out) :: beam type(beam_data_t), intent(in), target :: beam_data end subroutine beam_init <>= module subroutine beam_init (beam, beam_data) type(beam_t), intent(out) :: beam type(beam_data_t), intent(in), target :: beam_data logical, dimension(beam_data%n) :: polarized, diagonal type(quantum_numbers_mask_t), dimension(beam_data%n) :: mask, mask_d type(state_matrix_t), target :: state_hel, state_fc, state_tmp type(state_iterator_t) :: it_hel, it_tmp type(quantum_numbers_t), dimension(:), allocatable :: qn complex(default) :: value real(default), parameter :: tolerance = 100 * epsilon (1._default) polarized = beam_data%pmatrix%is_polarized () diagonal = beam_data%pmatrix%is_diagonal () mask = quantum_numbers_mask (.false., .false., & mask_h = .not. polarized, & mask_hd = diagonal) mask_d = quantum_numbers_mask (.false., .false., .false., & mask_hd = polarized .and. diagonal) call beam%int%basic_init & (0, 0, beam_data%n, mask = mask, store_values = .true.) state_hel = beam_data%get_helicity_state_matrix () allocate (qn (beam_data%n)) call qn%init (beam_data%flv, color_from_flavor (beam_data%flv, 1)) call state_fc%init () call state_fc%add_state (qn) call merge_state_matrices (state_hel, state_fc, state_tmp) call it_hel%init (state_hel) call it_tmp%init (state_tmp) do while (it_hel%is_valid ()) qn = it_tmp%get_quantum_numbers () value = it_hel%get_matrix_element () if (any (qn%are_redundant (mask_d))) then ! skip off-diagonal elements for diagonal polarization else if (abs (value) <= tolerance) then ! skip zero entries else call beam%int%add_state (qn, value = value) end if call it_hel%advance () call it_tmp%advance () end do call beam%int%freeze () call beam%int%set_momenta (beam_data%p, outgoing = .true.) call state_hel%final () call state_fc%final () call state_tmp%final () end subroutine beam_init @ %def beam_init @ Finalizer: <>= public :: beam_final <>= module subroutine beam_final (beam) type(beam_t), intent(inout) :: beam end subroutine beam_final <>= module subroutine beam_final (beam) type(beam_t), intent(inout) :: beam call beam%int%final () end subroutine beam_final @ %def beam_final @ I/O: <>= public :: beam_write <>= module subroutine beam_write & (beam, unit, verbose, show_momentum_sum, show_mass, col_verbose) type(beam_t), intent(in) :: beam integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, show_momentum_sum, show_mass logical, intent(in), optional :: col_verbose end subroutine beam_write <>= module subroutine beam_write & (beam, unit, verbose, show_momentum_sum, show_mass, col_verbose) type(beam_t), intent(in) :: beam integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, show_momentum_sum, show_mass logical, intent(in), optional :: col_verbose integer :: u u = given_output_unit (unit); if (u < 0) return select case (beam%int%get_n_out ()) case (1); write (u, *) "Decaying particle:" case (2); write (u, *) "Colliding beams:" end select call beam%int%basic_write & (unit, verbose = verbose, show_momentum_sum = & show_momentum_sum, show_mass = show_mass, & col_verbose = col_verbose) end subroutine beam_write @ %def beam_write @ Defined assignment: deep copy <>= public :: assignment(=) <>= interface assignment(=) module procedure beam_assign end interface <>= module subroutine beam_assign (beam_out, beam_in) type(beam_t), intent(out) :: beam_out type(beam_t), intent(in) :: beam_in end subroutine beam_assign <>= module subroutine beam_assign (beam_out, beam_in) type(beam_t), intent(out) :: beam_out type(beam_t), intent(in) :: beam_in beam_out%int = beam_in%int end subroutine beam_assign @ %def beam_assign @ \subsection{Inherited procedures} <>= public :: interaction_set_source_link_beam <>= module subroutine interaction_set_source_link_beam (int, i, beam1, i1) type(interaction_t), intent(inout) :: int type(beam_t), intent(in), target :: beam1 integer, intent(in) :: i, i1 end subroutine interaction_set_source_link_beam <>= module subroutine interaction_set_source_link_beam (int, i, beam1, i1) type(interaction_t), intent(inout) :: int type(beam_t), intent(in), target :: beam1 integer, intent(in) :: i, i1 call int%set_source_link (i, beam1%int, i1) end subroutine interaction_set_source_link_beam @ %def interaction_set_source_link_beam @ \subsection{Accessing contents} Return the interaction component -- as a pointer, to avoid any copying. <>= public :: beam_get_int_ptr <>= module function beam_get_int_ptr (beam) result (int) type(interaction_t), pointer :: int type(beam_t), intent(in), target :: beam end function beam_get_int_ptr <>= module function beam_get_int_ptr (beam) result (int) type(interaction_t), pointer :: int type(beam_t), intent(in), target :: beam int => beam%int end function beam_get_int_ptr @ %def beam_get_int_ptr @ Set beam momenta directly. (Used for cascade decays.) <>= public :: beam_set_momenta <>= module subroutine beam_set_momenta (beam, p) type(beam_t), intent(inout) :: beam type(vector4_t), dimension(:), intent(in) :: p end subroutine beam_set_momenta <>= module subroutine beam_set_momenta (beam, p) type(beam_t), intent(inout) :: beam type(vector4_t), dimension(:), intent(in) :: p call beam%int%set_momenta (p) end subroutine beam_set_momenta @ %def beam_set_momenta @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[beams_ut.f90]]>>= <> module beams_ut use unit_tests use beams_uti <> <> contains <> end module beams_ut @ %def beams_ut @ <<[[beams_uti.f90]]>>= <> module beams_uti <> use lorentz use flavors use interactions, only: reset_interaction_counter use polarizations, only: smatrix_t use model_data use beam_structures use beams <> <> contains <> end module beams_uti @ %def beams_ut @ API: driver for the unit tests below. <>= public :: beams_test <>= subroutine beams_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine beams_test @ %def beams_test @ Test the basic beam setup. <>= call test (beam_1, "beam_1", & "check basic beam setup", & u, results) <>= public :: beam_1 <>= subroutine beam_1 (u) integer, intent(in) :: u type(beam_data_t), target :: beam_data type(beam_t) :: beam real(default) :: sqrts type(flavor_t), dimension(2) :: flv type(smatrix_t), dimension(2) :: smatrix real(default), dimension(2) :: pol_f type(model_data_t), target :: model write (u, "(A)") "* Test output: beam_1" write (u, "(A)") "* Purpose: test basic beam setup" write (u, "(A)") write (u, "(A)") "* Reading model file" write (u, "(A)") call reset_interaction_counter () call model%init_sm_test () write (u, "(A)") "* Unpolarized scattering, massless fermions" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([1,-1], model) call beam_data%init_sqrts (sqrts, flv) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized scattering, massless bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([22,22], model) call beam_data%init_sqrts (sqrts, flv) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized scattering, massive bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([24,-24], model) call beam_data%init_sqrts (sqrts, flv) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Polarized scattering, massless fermions" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([1,-1], model) call smatrix(1)%init (2, 1) call smatrix(1)%set_entry (1, [1,1], (1._default, 0._default)) pol_f(1) = 0.5_default call smatrix(2)%init (2, 3) call smatrix(2)%set_entry (1, [1,1], (1._default, 0._default)) call smatrix(2)%set_entry (2, [-1,-1], (1._default, 0._default)) call smatrix(2)%set_entry (3, [-1,1], (1._default, 0._default)) pol_f(2) = 1._default call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Semi-polarized scattering, massless bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([22,22], model) call smatrix(1)%init (2, 0) pol_f(1) = 0._default call smatrix(2)%init (2, 1) call smatrix(2)%set_entry (1, [1,1], (1._default, 0._default)) pol_f(2) = 1._default call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Semi-polarized scattering, massive bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([24,-24], model) call smatrix(1)%init (2, 0) pol_f(1) = 0._default call smatrix(2)%init (2, 1) call smatrix(2)%set_entry (1, [0,0], (1._default, 0._default)) pol_f(2) = 1._default call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized decay, massive boson" write (u, "(A)") call reset_interaction_counter () call flv(1)%init (23, model) call beam_data%init_decay (flv(1:1)) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Polarized decay, massive boson" write (u, "(A)") call reset_interaction_counter () call flv(1)%init (23, model) call smatrix(1)%init (2, 1) call smatrix(1)%set_entry (1, [0,0], (1._default, 0._default)) pol_f(1) = 0.4_default call beam_data%init_decay (flv(1:1), smatrix(1:1), pol_f(1:1)) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Cleanup" call beam_final (beam) call beam_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: beam_1" end subroutine beam_1 @ %def beam_1 @ Test advanced beam setup. <>= call test (beam_2, "beam_2", & "beam initialization", & u, results) <>= public :: beam_2 <>= subroutine beam_2 (u) integer, intent(in) :: u type(beam_data_t), target :: beam_data type(beam_t) :: beam real(default) :: sqrts type(flavor_t), dimension(2) :: flv integer, dimension(0) :: no_records type(beam_structure_t) :: beam_structure type(model_data_t), target :: model write (u, "(A)") "* Test output: beam_2" write (u, "(A)") "* Purpose: transfer beam polarization using & &beam structure" write (u, "(A)") write (u, "(A)") "* Reading model file" write (u, "(A)") call model%init_sm_test () write (u, "(A)") "* Unpolarized scattering, massless fermions" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([1,-1], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%final_pol () call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized scattering, massless bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([22,22], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%final_pol () call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized scattering, massive bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([24,-24], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%final_pol () call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Polarized scattering, massless fermions" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([1,-1], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%init_pol (2) call beam_structure%init_smatrix (1, 1) call beam_structure%set_sentry (1, 1, [1,1], (1._default, 0._default)) call beam_structure%init_smatrix (2, 3) call beam_structure%set_sentry (2, 1, [1,1], (1._default, 0._default)) call beam_structure%set_sentry (2, 2, [-1,-1], (1._default, 0._default)) call beam_structure%set_sentry (2, 3, [-1,1], (1._default, 0._default)) call beam_structure%set_pol_f ([0.5_default, 1._default]) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, *) call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () call beam_structure%final_pol () call beam_structure%final_sf () write (u, "(A)") write (u, "(A)") "* Semi-polarized scattering, massless bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([22,22], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%init_pol (2) call beam_structure%init_smatrix (1, 0) call beam_structure%init_smatrix (2, 1) call beam_structure%set_sentry (2, 1, [1,1], (1._default, 0._default)) call beam_structure%set_pol_f ([0._default, 1._default]) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Semi-polarized scattering, massive bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([24,-24], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%init_pol (2) call beam_structure%init_smatrix (1, 0) call beam_structure%init_smatrix (2, 1) call beam_structure%set_sentry (2, 1, [0,0], (1._default, 0._default)) call beam_structure%write (u) write (u, "(A)") call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized decay, massive boson" write (u, "(A)") call reset_interaction_counter () call flv(1)%init (23, model) call beam_structure%init_sf ([flv(1)%get_name ()], no_records) call beam_structure%final_pol () call beam_structure%write (u) write (u, "(A)") call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Polarized decay, massive boson" write (u, "(A)") call reset_interaction_counter () call flv(1)%init (23, model) call beam_structure%init_sf ([flv(1)%get_name ()], no_records) call beam_structure%init_pol (1) call beam_structure%init_smatrix (1, 1) call beam_structure%set_sentry (1, 1, [0,0], (1._default, 0._default)) call beam_structure%set_pol_f ([0.4_default]) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Cleanup" call beam_final (beam) call beam_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: beam_2" end subroutine beam_2 @ %def beam_2 @ Test advanced beam setup, completely arbitrary momenta. <>= call test (beam_3, "beam_3", & "generic beam momenta", & u, results) <>= public :: beam_3 <>= subroutine beam_3 (u) integer, intent(in) :: u type(beam_data_t), target :: beam_data type(beam_t) :: beam type(flavor_t), dimension(2) :: flv integer, dimension(0) :: no_records type(model_data_t), target :: model type(beam_structure_t) :: beam_structure type(vector3_t), dimension(2) :: p3 type(vector4_t), dimension(2) :: p write (u, "(A)") "* Test output: beam_3" write (u, "(A)") "* Purpose: set up beams with generic momenta" write (u, "(A)") write (u, "(A)") "* Reading model file" write (u, "(A)") call reset_interaction_counter () call model%init_sm_test () write (u, "(A)") "* 1: Scattering process" write (u, "(A)") call flv%init ([2212,2212], model) p3(1) = vector3_moving ([5._default, 0._default, 10._default]) p3(2) = -vector3_moving ([1._default, 1._default, -10._default]) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%set_momentum (p3 ** 1) call beam_structure%set_theta (polar_angle (p3)) call beam_structure%set_phi (azimuthal_angle (p3)) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, 0._default, model) call pacify (beam_data%l_cm_to_lab, 1e-20_default) call beam_data%compute_md5sum () call beam_data%write (u, verbose = .true.) write (u, *) write (u, "(1x,A)") "Beam momenta reconstructed from LT:" p = beam_data%L_cm_to_lab * beam_data%p_cm call pacify (p, 1e-12_default) call vector4_write (p(1), u) call vector4_write (p(2), u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () call beam_structure%final_sf () call beam_structure%final_mom () write (u, "(A)") write (u, "(A)") "* 2: Decay" write (u, "(A)") call flv(1)%init (23, model) p3(1) = vector3_moving ([10._default, 5._default, 50._default]) call beam_structure%init_sf ([flv(1)%get_name ()], no_records) call beam_structure%set_momentum ([p3(1) ** 1]) call beam_structure%set_theta ([polar_angle (p3(1))]) call beam_structure%set_phi ([azimuthal_angle (p3(1))]) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, 0._default, model) call beam_data%write (u, verbose = .true.) write (u, "(A)") write (u, "(1x,A)") "Beam momentum reconstructed from LT:" p(1) = beam_data%L_cm_to_lab * beam_data%p_cm(1) call pacify (p(1), 1e-12_default) call vector4_write (p(1), u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Cleanup" call beam_final (beam) call beam_data%final () call beam_structure%final_sf () call beam_structure%final_mom () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: beam_3" end subroutine beam_3 @ %def beam_3 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Tools} This module contains auxiliary procedures that can be accessed by the structure function code. <<[[sf_aux.f90]]>>= <> module sf_aux <> use constants, only: twopi use lorentz <> <> <> <> interface <> end interface end module sf_aux @ %def sf_aux @ <<[[sf_aux_sub.f90]]>>= <> submodule (sf_aux) sf_aux_s use io_units use numeric_utils implicit none contains <> end submodule sf_aux_s @ %def sf_aux_s @ \subsection{Momentum splitting} Let us consider first an incoming parton with momentum $k$ and invariant mass squared $s=k^2$ that splits into two partons with momenta $q,p$ and invariant masses $t=q^2$ and $u=p^2$. (This is an abuse of the Mandelstam notation. $t$ is actually the momentum transfer, assuming that $p$ is radiated and $q$ initiates the hard process.) The energy is split among the partons such that if $E=k^0$, we have $q^0 = xE$ and $p^0=\bar x E$, where $\bar x\equiv 1-x$. We define the angle $\theta$ as the polar angle of $p$ w.r.t.\ the momentum axis of the incoming momentum $k$. Ignoring azimuthal angle, we can write the four-momenta in the basis $(E,p_T,p_L)$ as \begin{equation} k = \begin{pmatrix} E \\ 0 \\ p \end{pmatrix}, \qquad p = \begin{pmatrix} \bar x E \\ \bar x\bar p\sin\theta \\ \bar x\bar p\cos\theta \end{pmatrix}, \qquad q = \begin{pmatrix} x E \\ -\bar x\bar p\sin\theta \\ p - \bar x\bar p\cos\theta \end{pmatrix}, \end{equation} where the first two mass-shell conditions are \begin{equation} p^2 = E^2 - s, \qquad \bar p^2 = E^2 - \frac{u}{\bar x^2}. \end{equation} The second condition implies that, for positive $u$, $\bar x^2 > u/E^2$, or equivalently \begin{equation} x < 1 - \sqrt{u} / E. \end{equation} We are interested in the third mass-shell conditions: $s$ and $u$ are fixed, so we need $t$ as a function of $\cos\theta$: \begin{equation} t = -2\bar x \left(E^2 - p\bar p\cos\theta\right) + s + u. \end{equation} Solving for $\cos\theta$, we get \begin{equation} \cos\theta = \frac{2\bar x E^2 + t - s - u}{2\bar x p\bar p}. \end{equation} We can compute $\sin\theta$ numerically as $\sin^2\theta=1-\cos^2\theta$, but it is important to reexpress this in view of numerical stability. To this end, we first determine the bounds for $t$. The cosine must be between $-1$ and $1$, so the bounds are \begin{align} t_0 &= -2\bar x\left(E^2 + p\bar p\right) + s + u, \\ t_1 &= -2\bar x\left(E^2 - p\bar p\right) + s + u. \end{align} Computing $\sin^2\theta$ from $\cos\theta$ above, we observe that the numerator is a quadratic polynomial in $t$ which has the zeros $t_0$ and $t_1$, while the common denominator is given by $(2\bar x p\bar p)^2$. Hence, we can write \begin{equation} \sin^2\theta = -\frac{(t - t_0)(t - t_1)}{(2\bar x p\bar p)^2} \qquad\text{and}\qquad \cos\theta = \frac{(t-t_0) + (t-t_1)}{4\bar x p\bar p}, \end{equation} which is free of large cancellations near $t=t_0$ or $t=t_1$. If all is massless, i.e., $s=u=0$, this simplifies to \begin{align} t_0 &= -4\bar x E^2, & t_1 &= 0, \\ \sin^2\theta &= -\frac{t}{\bar x E^2} \left(1 + \frac{t}{4\bar x E^2}\right), & \cos\theta &= 1 + \frac{t}{2\bar x E^2}. \end{align} Here is the implementation. First, we define a container for the kinematical integration limits and some further data. Note: contents are public only for easy access in unit test. <>= public :: splitting_data_t <>= type :: splitting_data_t ! private logical :: collinear = .false. real(default) :: x0 = 0 real(default) :: x1 real(default) :: t0 real(default) :: t1 real(default) :: phi0 = 0 real(default) :: phi1 = twopi real(default) :: E, p, s, u, m2 real(default) :: x, xb, pb real(default) :: t = 0 real(default) :: phi = 0 contains <> end type splitting_data_t @ %def splitting_data_t @ I/O for debugging: <>= procedure :: write => splitting_data_write <>= module subroutine splitting_data_write (d, unit) class(splitting_data_t), intent(in) :: d integer, intent(in), optional :: unit end subroutine splitting_data_write <>= module subroutine splitting_data_write (d, unit) class(splitting_data_t), intent(in) :: d integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(A)") "Splitting data:" write (u, "(2x,A,L1)") "collinear = ", d%collinear 1 format (2x,A,1x,ES15.8) write (u, 1) "x0 =", d%x0 write (u, 1) "x =", d%x write (u, 1) "xb =", d%xb write (u, 1) "x1 =", d%x1 write (u, 1) "t0 =", d%t0 write (u, 1) "t =", d%t write (u, 1) "t1 =", d%t1 write (u, 1) "phi0 =", d%phi0 write (u, 1) "phi =", d%phi write (u, 1) "phi1 =", d%phi1 write (u, 1) "E =", d%E write (u, 1) "p =", d%p write (u, 1) "pb =", d%pb write (u, 1) "s =", d%s write (u, 1) "u =", d%u write (u, 1) "m2 =", d%m2 end subroutine splitting_data_write @ %def splitting_data_write @ \subsection{Constant data} This is the initializer for the data. The input consists of the incoming momentum, its invariant mass squared, and the invariant mass squared of the radiated particle. $m2$ is the \emph{physical} mass squared of the outgoing particle. The $t$ bounds depend on the chosen $x$ value and cannot be determined yet. <>= procedure :: init => splitting_data_init <>= module subroutine splitting_data_init (d, k, mk2, mr2, mo2, collinear) class(splitting_data_t), intent(out) :: d type(vector4_t), intent(in) :: k real(default), intent(in) :: mk2, mr2, mo2 logical, intent(in), optional :: collinear end subroutine splitting_data_init <>= module subroutine splitting_data_init (d, k, mk2, mr2, mo2, collinear) class(splitting_data_t), intent(out) :: d type(vector4_t), intent(in) :: k real(default), intent(in) :: mk2, mr2, mo2 logical, intent(in), optional :: collinear if (present (collinear)) d%collinear = collinear d%E = energy (k) d%x1 = 1 - sqrt (max (mr2, 0._default)) / d%E d%p = sqrt (d%E**2 - mk2) d%s = mk2 d%u = mr2 d%m2 = mo2 end subroutine splitting_data_init @ %def splitting_data_init @ Retrieve the $x$ bounds, if needed for $x$ sampling. Generating an $x$ value is done by the caller, since this is the part that depends on the nature of the structure function. <>= procedure :: get_x_bounds => splitting_get_x_bounds <>= module function splitting_get_x_bounds (d) result (x) class(splitting_data_t), intent(in) :: d real(default), dimension(2) :: x end function splitting_get_x_bounds <>= module function splitting_get_x_bounds (d) result (x) class(splitting_data_t), intent(in) :: d real(default), dimension(2) :: x x = [ d%x0, d%x1 ] end function splitting_get_x_bounds @ %def splitting_get_x_bounds @ Now set the momentum fraction and compute $t_0$ and $t_1$. [The calculation of $t_1$ is subject to numerical problems. The exact formula is ($s=m_i^2$, $u=m_r^2$) \begin{equation} t_1 = -2\bar x E^2 + m_i^2 + m_r^2 + 2\bar x \sqrt{E^2-m_i^2}\,\sqrt{E^2 - m_r^2/\bar x^2}. \end{equation} The structure-function paradigm is useful only if $E\gg m_i,m_r$. In a Taylor expansion for large $E$, the leading term cancels. The expansion of the square roots (to subleading order) yields \begin{equation} t_1 = xm_i^2 - \frac{x}{\bar x}m_r^2. \end{equation} There are two cases of interest: $m_i=m_o$ and $m_r=0$, \begin{equation} t_1 = xm_o^2 \end{equation} and $m_i=m_r$ and $m_o=0$, \begin{equation} t_1 = -\frac{x^2}{\bar x}m_i^2. \end{equation} In both cases, $t_1\leq m_o^2$.] That said, it turns out that taking the $t_1$ evaluation at face value leads to less problems than the approximation. We express the angles in terms of $t-t_0$ and $t-t_1$. Numerical noise in $t_1$ can then be tolerated. <>= procedure :: set_t_bounds => splitting_set_t_bounds <>= elemental module subroutine splitting_set_t_bounds (d, x, xb) class(splitting_data_t), intent(inout) :: d real(default), intent(in), optional :: x, xb end subroutine splitting_set_t_bounds <>= elemental module subroutine splitting_set_t_bounds (d, x, xb) class(splitting_data_t), intent(inout) :: d real(default), intent(in), optional :: x, xb real(default) :: tp, tm if (present (x)) d%x = x if (present (xb)) d%xb = xb if (vanishes (d%u)) then d%pb = d%E else if (.not. vanishes (d%xb)) then d%pb = sqrt (max (d%E**2 - d%u / d%xb**2, 0._default)) else d%pb = 0 end if end if tp = -2 * d%xb * d%E**2 + d%s + d%u tm = -2 * d%xb * d%p * d%pb d%t0 = tp + tm d%t1 = tp - tm d%t = d%t1 end subroutine splitting_set_t_bounds @ %def splitting_set_t_bounds @ \subsection{Sampling recoil} Compute a value for the momentum transfer $t$, using a random number $r$. We assume a logarithmic distribution for $t-m^2$, corresponding to the propagator $1/(t-m^2)$ with the physical mass $m$ for the outgoing particle. Optionally, we can narrow the kinematical bounds. If all three masses in the splitting vanish, the upper limit for $t$ is zero. In that case, the $t$ value is set to zero and the splitting will be collinear. <>= procedure :: sample_t => splitting_sample_t <>= module subroutine splitting_sample_t (d, r, t0, t1) class(splitting_data_t), intent(inout) :: d real(default), intent(in) :: r real(default), intent(in), optional :: t0, t1 end subroutine splitting_sample_t <>= module subroutine splitting_sample_t (d, r, t0, t1) class(splitting_data_t), intent(inout) :: d real(default), intent(in) :: r real(default), intent(in), optional :: t0, t1 real(default) :: tt0, tt1, tt0m, tt1m if (d%collinear) then d%t = d%t1 else tt0 = d%t0; if (present (t0)) tt0 = max (t0, tt0) tt1 = d%t1; if (present (t1)) tt1 = min (t1, tt1) tt0m = tt0 - d%m2 tt1m = tt1 - d%m2 if (tt0m < 0 .and. tt1m < 0 .and. abs(tt0m) > & epsilon(tt0m) .and. abs(tt1m) > epsilon(tt0m)) then d%t = d%m2 + tt0m * exp (r * log (tt1m / tt0m)) else d%t = tt1 end if end if end subroutine splitting_sample_t @ %def splitting_sample_t @ The inverse operation: Given $t$, we recover the value of $r$ that would have produced this value. <>= procedure :: inverse_t => splitting_inverse_t <>= module subroutine splitting_inverse_t (d, r, t0, t1) class(splitting_data_t), intent(in) :: d real(default), intent(out) :: r real(default), intent(in), optional :: t0, t1 end subroutine splitting_inverse_t <>= module subroutine splitting_inverse_t (d, r, t0, t1) class(splitting_data_t), intent(in) :: d real(default), intent(out) :: r real(default), intent(in), optional :: t0, t1 real(default) :: tt0, tt1, tt0m, tt1m if (d%collinear) then r = 0 else tt0 = d%t0; if (present (t0)) tt0 = max (t0, tt0) tt1 = d%t1; if (present (t1)) tt1 = min (t1, tt1) tt0m = tt0 - d%m2 tt1m = tt1 - d%m2 if (tt0m < 0 .and. tt1m < 0) then r = log ((d%t - d%m2) / tt0m) / log (tt1m / tt0m) else r = 0 end if end if end subroutine splitting_inverse_t @ %def splitting_inverse_t @ This is trivial, but provided for convenience: <>= procedure :: sample_phi => splitting_sample_phi <>= module subroutine splitting_sample_phi (d, r) class(splitting_data_t), intent(inout) :: d real(default), intent(in) :: r end subroutine splitting_sample_phi <>= module subroutine splitting_sample_phi (d, r) class(splitting_data_t), intent(inout) :: d real(default), intent(in) :: r if (d%collinear) then d%phi = 0 else d%phi = (1-r) * d%phi0 + r * d%phi1 end if end subroutine splitting_sample_phi @ %def splitting_sample_phi @ Inverse: <>= procedure :: inverse_phi => splitting_inverse_phi <>= module subroutine splitting_inverse_phi (d, r) class(splitting_data_t), intent(in) :: d real(default), intent(out) :: r end subroutine splitting_inverse_phi <>= module subroutine splitting_inverse_phi (d, r) class(splitting_data_t), intent(in) :: d real(default), intent(out) :: r if (d%collinear) then r = 0 else r = (d%phi - d%phi0) / (d%phi1 - d%phi0) end if end subroutine splitting_inverse_phi @ %def splitting_inverse_phi @ \subsection{Splitting} In this function, we actually perform the splitting. The incoming momentum $k$ is split into (if no recoil) $q_1=(1-x)k$ and $q_2=xk$. Apart from the splitting data, we need the incoming momentum $k$, the momentum transfer $t$, and the azimuthal angle $\phi$. The momentum fraction $x$ is already known here. Alternatively, we can split without recoil. The azimuthal angle is irrelevant, and the momentum transfer is always equal to the upper limit $t_1$, so the polar angle is zero. Obviously, if there are nonzero masses it is not possible to keep both energy-momentum conservation and at the same time all particles on shell. We choose for dropping the on-shell condition here. <>= procedure :: split_momentum => splitting_split_momentum <>= module function splitting_split_momentum (d, k) result (q) class(splitting_data_t), intent(in) :: d type(vector4_t), dimension(2) :: q type(vector4_t), intent(in) :: k end function splitting_split_momentum <>= module function splitting_split_momentum (d, k) result (q) class(splitting_data_t), intent(in) :: d type(vector4_t), dimension(2) :: q type(vector4_t), intent(in) :: k real(default) :: st2, ct2, st, ct, cp, sp type(lorentz_transformation_t) :: rot real(default) :: tt0, tt1, den type(vector3_t) :: kk, q1, q2 if (d%collinear) then if (vanishes (d%s) .and. vanishes(d%u)) then q(1) = d%xb * k q(2) = d%x * k else kk = space_part (k) q1 = d%xb * (d%pb / d%p) * kk q2 = kk - q1 q(1) = vector4_moving (d%xb * d%E, q1) q(2) = vector4_moving (d%x * d%E, q2) end if else den = 2 * d%xb * d%p * d%pb tt0 = max (d%t - d%t0, 0._default) tt1 = min (d%t - d%t1, 0._default) if (den**2 <= epsilon(den)) then st2 = 0 else st2 = - (tt0 * tt1) / den ** 2 end if if (st2 > 1) then st2 = 1 end if ct2 = 1 - st2 st = sqrt (max (st2, 0._default)) ct = sqrt (max (ct2, 0._default)) if ((d%t - d%t0 + d%t - d%t1) < 0) then ct = - ct end if sp = sin (d%phi) cp = cos (d%phi) rot = rotation_to_2nd (3, space_part (k)) q1 = vector3_moving (d%xb * d%pb * [st * cp, st * sp, ct]) q2 = vector3_moving (d%p, 3) - q1 q(1) = rot * vector4_moving (d%xb * d%E, q1) q(2) = rot * vector4_moving (d%x * d%E, q2) end if end function splitting_split_momentum @ %def splitting_split_momentum @ Momenta generated by splitting will in general be off-shell. They are on-shell only if they are collinear and massless. This subroutine puts them on shell by brute force, violating either momentum or energy conservation. The direction of three-momentum is always retained. If the energy is below mass shell, we return a zero momentum. <>= integer, parameter, public :: KEEP_ENERGY = 0, KEEP_MOMENTUM = 1 @ %def KEEP_ENERGY KEEP_MOMENTUM <>= public :: on_shell <>= elemental module subroutine on_shell (p, m2, keep) type(vector4_t), intent(inout) :: p real(default), intent(in) :: m2 integer, intent(in) :: keep end subroutine on_shell <>= elemental module subroutine on_shell (p, m2, keep) type(vector4_t), intent(inout) :: p real(default), intent(in) :: m2 integer, intent(in) :: keep real(default) :: E, E2, pn select case (keep) case (KEEP_ENERGY) E = energy (p) E2 = E ** 2 if (E2 >= m2) then pn = sqrt (E2 - m2) p = vector4_moving (E, pn * direction (space_part (p))) else p = vector4_null end if case (KEEP_MOMENTUM) E = sqrt (space_part (p) ** 2 + m2) p = vector4_moving (E, space_part (p)) end select end subroutine on_shell @ %def on_shell @ \subsection{Recovering the splitting} This is the inverse problem. We have on-shell momenta and want to deduce the splitting parameters $x$, $t$, and $\phi$. Update 2018-08-22: As a true inverse to [[splitting_split_momentum]], we now use not just a single momentum [[q2]] as before, but the momentum pair [[q1]], [[q2]] for recovering $x$ and $\bar x$ separately. If $x$ happens to be close to $1$, we would completely lose the tiny $\bar x$ value, otherwise, and thus get a meaningless result. <>= procedure :: recover => splitting_recover <>= module subroutine splitting_recover (d, k, q, keep) class(splitting_data_t), intent(inout) :: d type(vector4_t), intent(in) :: k type(vector4_t), dimension(2), intent(in) :: q integer, intent(in) :: keep end subroutine splitting_recover <>= module subroutine splitting_recover (d, k, q, keep) class(splitting_data_t), intent(inout) :: d type(vector4_t), intent(in) :: k type(vector4_t), dimension(2), intent(in) :: q integer, intent(in) :: keep type(lorentz_transformation_t) :: rot type(vector4_t) :: k0 type(vector4_t), dimension(2) :: q0 real(default) :: p1, p2, p3, pt2, pp2, pl real(default) :: aux, den, norm real(default) :: st2, ct2, ct rot = inverse (rotation_to_2nd (3, space_part (k))) q0 = rot * q p1 = vector4_get_component (q0(2), 1) p2 = vector4_get_component (q0(2), 2) p3 = vector4_get_component (q0(2), 3) pt2 = p1 ** 2 + p2 ** 2 pp2 = p1 ** 2 + p2 ** 2 + p3 ** 2 pl = abs (p3) k0 = vector4_moving (d%E, d%p, 3) select case (keep) case (KEEP_ENERGY) d%x = energy (q0(2)) / d%E d%xb = energy (q0(1)) / d%E call d%set_t_bounds () if (.not. d%collinear) then aux = (d%xb * d%pb) ** 2 * pp2 - d%p ** 2 * pt2 den = d%p ** 2 - (d%xb * d%pb) ** 2 if (aux >= 0 .and. den > 0) then norm = (d%p * pl + sqrt (aux)) / den else norm = 1 end if end if case (KEEP_MOMENTUM) d%xb = sqrt (space_part (q0(1)) ** 2 + d%u) / d%E d%x = 1 - d%xb call d%set_t_bounds () norm = 1 end select if (d%collinear) then d%t = d%t1 d%phi = 0 else if ((d%xb * d%pb * norm)**2 < epsilon(d%xb)) then st2 = 1 else st2 = pt2 / (d%xb * d%pb * norm ) ** 2 end if if (st2 > 1) then st2 = 1 end if ct2 = 1 - st2 ct = sqrt (max (ct2, 0._default)) if (.not. vanishes (1 + ct)) then d%t = d%t1 - 2 * d%xb * d%p * d%pb * st2 / (1 + ct) else d%t = d%t0 end if if (.not. vanishes (p1) .or. .not. vanishes (p2)) then d%phi = atan2 (-p2, -p1) else d%phi = 0 end if end if end subroutine splitting_recover @ %def splitting_recover @ \subsection{Extract data} <>= procedure :: get_x => splitting_get_x procedure :: get_xb => splitting_get_xb <>= module function splitting_get_x (sd) result (x) class(splitting_data_t), intent(in) :: sd real(default) :: x end function splitting_get_x module function splitting_get_xb (sd) result (xb) class(splitting_data_t), intent(in) :: sd real(default) :: xb end function splitting_get_xb <>= module function splitting_get_x (sd) result (x) class(splitting_data_t), intent(in) :: sd real(default) :: x x = sd%x end function splitting_get_x module function splitting_get_xb (sd) result (xb) class(splitting_data_t), intent(in) :: sd real(default) :: xb xb = sd%xb end function splitting_get_xb @ %def splitting_get_x @ %def splitting_get_xb @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_aux_ut.f90]]>>= <> module sf_aux_ut use unit_tests use sf_aux_uti <> <> contains <> end module sf_aux_ut @ %def sf_aux_ut @ <<[[sf_aux_uti.f90]]>>= <> module sf_aux_uti <> use numeric_utils, only: pacify use lorentz use sf_aux <> <> contains <> end module sf_aux_uti @ %def sf_aux_ut @ API: driver for the unit tests below. <>= public :: sf_aux_test <>= subroutine sf_aux_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_aux_test @ %def sf_aux_test @ \subsubsection{Momentum splitting: massless radiation} Compute momentum splitting for generic kinematics. It turns out that for $x=0.5$, where $t-m^2$ is the geometric mean between its upper and lower bounds (this can be directly seen from the logarithmic distribution in the function [[sample_t]] for $r \equiv x = 1 - x = 0.5$), we arrive at an exact number $t=-0.15$ for the given input values. <>= call test (sf_aux_1, "sf_aux_1", & "massless radiation", & u, results) <>= public :: sf_aux_1 <>= subroutine sf_aux_1 (u) integer, intent(in) :: u type(splitting_data_t) :: sd type(vector4_t) :: k type(vector4_t), dimension(2) :: q, q0 real(default) :: E, mk, mp, mq real(default) :: x, r1, r2, r1o, r2o real(default) :: k2, q0_2, q1_2, q2_2 write (u, "(A)") "* Test output: sf_aux_1" write (u, "(A)") "* Purpose: compute momentum splitting" write (u, "(A)") " (massless radiated particle)" write (u, "(A)") E = 1 mk = 0.3_default mp = 0 mq = mk k = vector4_moving (E, sqrt (E**2 - mk**2), 3) k2 = k ** 2; call pacify (k2, 1e-10_default) x = 0.6_default r1 = 0.5_default r2 = 0.125_default write (u, "(A)") "* (1) Non-collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%sample_t (r1) call sd%sample_phi (r2) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "Extract: x, 1-x" write (u, "(2(1x,F11.8))") sd%get_x (), sd%get_xb () write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q0_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q0_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (2) Collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, 1 - x) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q0_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q0_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: sf_aux_1" end subroutine sf_aux_1 @ %def sf_aux_1 @ \subsubsection{Momentum splitting: massless parton} Compute momentum splitting for generic kinematics. It turns out that for $x=0.5$, where $t-m^2$ is the geometric mean between its upper and lower bounds, we arrive at an exact number $t=-0.36$ for the given input values. <>= call test (sf_aux_2, "sf_aux_2", & "massless parton", & u, results) <>= public :: sf_aux_2 <>= subroutine sf_aux_2 (u) integer, intent(in) :: u type(splitting_data_t) :: sd type(vector4_t) :: k type(vector4_t), dimension(2) :: q, q0 real(default) :: E, mk, mp, mq real(default) :: x, r1, r2, r1o, r2o real(default) :: k2, q02_2, q1_2, q2_2 write (u, "(A)") "* Test output: sf_aux_2" write (u, "(A)") "* Purpose: compute momentum splitting" write (u, "(A)") " (massless outgoing particle)" write (u, "(A)") E = 1 mk = 0.3_default mp = mk mq = 0 k = vector4_moving (E, sqrt (E**2 - mk**2), 3) k2 = k ** 2; call pacify (k2, 1e-10_default) x = 0.6_default r1 = 0.5_default r2 = 0.125_default write (u, "(A)") "* (1) Non-collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%sample_t (r1) call sd%sample_phi (r2) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (2) Collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, 1 - x) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: sf_aux_2" end subroutine sf_aux_2 @ %def sf_aux_2 @ \subsubsection{Momentum splitting: all massless} Compute momentum splitting for massless kinematics. In the non-collinear case, we need a lower cutoff for $|t|$, otherwise a logarithmic distribution is not possible. <>= call test (sf_aux_3, "sf_aux_3", & "massless parton", & u, results) <>= public :: sf_aux_3 <>= subroutine sf_aux_3 (u) integer, intent(in) :: u type(splitting_data_t) :: sd type(vector4_t) :: k type(vector4_t), dimension(2) :: q, q0 real(default) :: E, mk, mp, mq, qmin, qmax real(default) :: x, r1, r2, r1o, r2o real(default) :: k2, q02_2, q1_2, q2_2 write (u, "(A)") "* Test output: sf_aux_3" write (u, "(A)") "* Purpose: compute momentum splitting" write (u, "(A)") " (all massless, q cuts)" write (u, "(A)") E = 1 mk = 0 mp = 0 mq = 0 qmin = 1e-2_default qmax = 1e0_default k = vector4_moving (E, sqrt (E**2 - mk**2), 3) k2 = k ** 2; call pacify (k2, 1e-10_default) x = 0.6_default r1 = 0.5_default r2 = 0.125_default write (u, "(A)") "* (1) Non-collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%sample_t (r1, t1 = - qmin ** 2, t0 = - qmax **2) call sd%sample_phi (r2) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o, t1 = - qmin ** 2, t0 = - qmax **2) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o, t1 = - qmin ** 2, t0 = - qmax **2) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (2) Collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, 1 - x) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: sf_aux_3" end subroutine sf_aux_3 @ %def sf_aux_3 @ \subsubsection{Endpoint stability} Compute momentum splitting for collinear kinematics close to both endpoints. In particular, check both directions $x\to$ momenta and momenta $\to x$. For purely massless collinear splitting, the [[KEEP_XXX]] flag is irrelevant. We choose [[KEEP_ENERGY]] here. <>= call test (sf_aux_4, "sf_aux_4", & "endpoint numerics", & u, results) <>= public :: sf_aux_4 <>= subroutine sf_aux_4 (u) integer, intent(in) :: u type(splitting_data_t) :: sd type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E, mk, mp, mq, qmin, qmax real(default) :: x, xb write (u, "(A)") "* Test output: sf_aux_4" write (u, "(A)") "* Purpose: compute massless collinear splitting near endpoint" E = 1 mk = 0 mp = 0 mq = 0 qmin = 1e-2_default qmax = 1e0_default k = vector4_moving (E, sqrt (E**2 - mk**2), 3) x = 0.1_default xb = 1 - x write (u, "(A)") write (u, "(A)") "* (1) Collinear setup, moderate kinematics" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%write (u) q = sd%split_momentum (k) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momenta" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%recover (k, q, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") xb, sd%xb write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (2) Close to x=0" write (u, "(A)") x = 1e-9_default xb = 1 - x call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%write (u) q = sd%split_momentum (k) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momenta" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%recover (k, q, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") xb, sd%xb write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (3) Close to x=1" write (u, "(A)") xb = 1e-9_default x = 1 - xb call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%write (u) q = sd%split_momentum (k) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momenta" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%recover (k, q, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") xb, sd%xb write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: sf_aux_4" end subroutine sf_aux_4 @ %def sf_aux_4 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Mappings for structure functions} In this module, we provide a wrapper for useful mappings of the unit (hyper-)square that we can apply to a set of structure functions. In some cases it is useful, or even mandatory, to map the MC input parameters nontrivially onto a set of structure functions for the two beams. In all cases considered here, instead of $x_1,x_2,\ldots$ as parameters for the beams, we generate one parameter that is equal, or related to, the product $x_1x_2\cdots$ (so it directly corresponds to $\sqrt{s}$). The other parameters describe the distribution of energy (loss) between beams and radiations. <<[[sf_mappings.f90]]>>= <> module sf_mappings <> use kinds, only: double <> <> <> <> <> interface <> end interface contains <> end module sf_mappings @ %def sf_mappings @ <<[[sf_mappings_sub.f90]]>>= <> submodule (sf_mappings) sf_mappings_s use io_units use constants, only: pi, zero, one use numeric_utils use diagnostics implicit none contains <> end submodule sf_mappings_s @ %def sf_mappings_s @ \subsection{Base type} First, we define an abstract base type for the mapping. In all cases we need to store the indices of the parameters on which the mapping applies. Additional parameters can be stored in the extensions of this type. <>= public :: sf_mapping_t <>= type, abstract :: sf_mapping_t integer, dimension(:), allocatable :: i contains <> end type sf_mapping_t @ %def sf_mapping_t @ The output routine is deferred: <>= procedure (sf_mapping_write), deferred :: write <>= abstract interface subroutine sf_mapping_write (object, unit) import class(sf_mapping_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine sf_mapping_write end interface @ %def sf_mapping_write @ Initializer for the base type. The array of parameter indices is allocated but initialized to zero. <>= procedure :: base_init => sf_mapping_base_init <>= module subroutine sf_mapping_base_init (mapping, n_par) class(sf_mapping_t), intent(out) :: mapping integer, intent(in) :: n_par end subroutine sf_mapping_base_init <>= module subroutine sf_mapping_base_init (mapping, n_par) class(sf_mapping_t), intent(out) :: mapping integer, intent(in) :: n_par allocate (mapping%i (n_par)) mapping%i = 0 end subroutine sf_mapping_base_init @ %def sf_mapping_base_init @ Set an index value. <>= procedure :: set_index => sf_mapping_set_index <>= module subroutine sf_mapping_set_index (mapping, j, i) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i end subroutine sf_mapping_set_index <>= module subroutine sf_mapping_set_index (mapping, j, i) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i mapping%i(j) = i end subroutine sf_mapping_set_index @ %def sf_mapping_set_index @ Retrieve an index value. <>= procedure :: get_index => sf_mapping_get_index <>= module function sf_mapping_get_index (mapping, j) result (i) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: j integer :: i end function sf_mapping_get_index <>= module function sf_mapping_get_index (mapping, j) result (i) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: j integer :: i i = mapping%i(j) end function sf_mapping_get_index @ %def sf_mapping_get_index @ Return the dimensionality, i.e., the number of parameters. <>= procedure :: get_n_dim => sf_mapping_get_n_dim <>= module function sf_mapping_get_n_dim (mapping) result (n) class(sf_mapping_t), intent(in) :: mapping integer :: n end function sf_mapping_get_n_dim <>= module function sf_mapping_get_n_dim (mapping) result (n) class(sf_mapping_t), intent(in) :: mapping integer :: n n = size (mapping%i) end function sf_mapping_get_n_dim @ %def sf_mapping_get_n_dim @ Computation: the values [[p]] are the input parameters, the values [[r]] are the output parameters. The values [[rb]] are defined as $\bar r = 1 - r$, but provided explicitly. They allow us to avoid numerical problems near $r=1$. The extra parameter [[x_free]] indicates that the total energy has already been renormalized by this factor. We have to take such a factor into account in a resonance or on-shell mapping. The Jacobian is [[f]]. We modify only the two parameters indicated by the indices [[i]]. <>= procedure (sf_mapping_compute), deferred :: compute <>= abstract interface subroutine sf_mapping_compute (mapping, r, rb, f, p, pb, x_free) import class(sf_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_mapping_compute end interface @ %def sf_mapping_compute @ The inverse mapping. Use [[r]] and/or [[rb]] to reconstruct [[p]] and also compute [[f]]. <>= procedure (sf_mapping_inverse), deferred :: inverse <>= abstract interface subroutine sf_mapping_inverse (mapping, r, rb, f, p, pb, x_free) import class(sf_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_mapping_inverse end interface @ %def sf_mapping_inverse @ \subsection{Methods for self-tests} This is a shorthand for: inject parameters, compute the mapping, display results, compute the inverse, display again. We provide an output format for the parameters and, optionally, a different output format for the Jacobians. <>= procedure :: check => sf_mapping_check <>= module subroutine sf_mapping_check (mapping, u, p_in, pb_in, fmt_p, fmt_f) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: u real(default), dimension(:), intent(in) :: p_in, pb_in character(*), intent(in) :: fmt_p character(*), intent(in), optional :: fmt_f end subroutine sf_mapping_check <>= module subroutine sf_mapping_check (mapping, u, p_in, pb_in, fmt_p, fmt_f) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: u real(default), dimension(:), intent(in) :: p_in, pb_in character(*), intent(in) :: fmt_p character(*), intent(in), optional :: fmt_f real(default), dimension(size(p_in)) :: p, pb, r, rb real(default) :: f, tolerance tolerance = 1.5E-17_default p = p_in pb= pb_in call mapping%compute (r, rb, f, p, pb) call pacify (p, tolerance) call pacify (pb, tolerance) call pacify (r, tolerance) call pacify (rb, tolerance) write (u, "(3x,A,9(1x," // fmt_p // "))") "p =", p write (u, "(3x,A,9(1x," // fmt_p // "))") "pb=", pb write (u, "(3x,A,9(1x," // fmt_p // "))") "r =", r write (u, "(3x,A,9(1x," // fmt_p // "))") "rb=", rb if (present (fmt_f)) then write (u, "(3x,A,9(1x," // fmt_f // "))") "f =", f else write (u, "(3x,A,9(1x," // fmt_p // "))") "f =", f end if write (u, *) call mapping%inverse (r, rb, f, p, pb) call pacify (p, tolerance) call pacify (pb, tolerance) call pacify (r, tolerance) call pacify (rb, tolerance) write (u, "(3x,A,9(1x," // fmt_p // "))") "p =", p write (u, "(3x,A,9(1x," // fmt_p // "))") "pb=", pb write (u, "(3x,A,9(1x," // fmt_p // "))") "r =", r write (u, "(3x,A,9(1x," // fmt_p // "))") "rb=", rb if (present (fmt_f)) then write (u, "(3x,A,9(1x," // fmt_f // "))") "f =", f else write (u, "(3x,A,9(1x," // fmt_p // "))") "f =", f end if write (u, *) write (u, "(3x,A,9(1x," // fmt_p // "))") "*r=", product (r) end subroutine sf_mapping_check @ %def sf_mapping_check @ This is a consistency check for the self-tests: the integral over the unit square should be unity. We estimate this by a simple binning and adding up the values; this should be sufficient for a self-test. The argument is the requested number of sampling points. We take the square root for binning in both dimensions, so the precise number might be different. <>= procedure :: integral => sf_mapping_integral <>= module function sf_mapping_integral (mapping, n_calls) result (integral) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: n_calls real(default) :: integral end function sf_mapping_integral <>= module function sf_mapping_integral (mapping, n_calls) result (integral) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: n_calls real(default) :: integral integer :: n_dim, n_bin, k real(default), dimension(:), allocatable :: p, pb, r, rb integer, dimension(:), allocatable :: ii real(default) :: dx, f, s n_dim = mapping%get_n_dim () allocate (p (n_dim)) allocate (pb(n_dim)) allocate (r (n_dim)) allocate (rb(n_dim)) allocate (ii(n_dim)) n_bin = nint (real (n_calls, default) ** (1._default / n_dim)) dx = 1._default / n_bin s = 0 ii = 1 SAMPLE: do do k = 1, n_dim p(k) = ii(k) * dx - dx/2 pb(k) = (n_bin - ii(k)) * dx + dx/2 end do call mapping%compute (r, rb, f, p, pb) s = s + f INCR: do k = 1, n_dim ii(k) = ii(k) + 1 if (ii(k) <= n_bin) then exit INCR else if (k < n_dim) then ii(k) = 1 else exit SAMPLE end if end do INCR end do SAMPLE integral = s / real (n_bin, default) ** n_dim end function sf_mapping_integral @ %def sf_mapping_integral @ \subsection{Implementation: standard mapping} This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio. <>= public :: sf_s_mapping_t <>= type, extends (sf_mapping_t) :: sf_s_mapping_t logical :: power_set = .false. real(default) :: power = 1 contains <> end type sf_s_mapping_t @ %def sf_s_mapping_t @ Output. <>= procedure :: write => sf_s_mapping_write <>= module subroutine sf_s_mapping_write (object, unit) class(sf_s_mapping_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine sf_s_mapping_write <>= module subroutine sf_s_mapping_write (object, unit) class(sf_s_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A)") ": standard (", object%power, ")" end subroutine sf_s_mapping_write @ %def sf_s_mapping_write @ Initialize: index pair and power parameter. <>= procedure :: init => sf_s_mapping_init <>= module subroutine sf_s_mapping_init (mapping, power) class(sf_s_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: power end subroutine sf_s_mapping_init <>= module subroutine sf_s_mapping_init (mapping, power) class(sf_s_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: power call mapping%base_init (2) if (present (power)) then mapping%power_set = .true. mapping%power = power end if end subroutine sf_s_mapping_init @ %def sf_s_mapping_init @ Apply mapping. <>= procedure :: compute => sf_s_mapping_compute <>= module subroutine sf_s_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_s_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_s_mapping_compute <>= module subroutine sf_s_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_s_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2 integer :: j if (mapping%power_set) then call map_unit_square (r2, f, p(mapping%i), mapping%power) else call map_unit_square (r2, f, p(mapping%i)) end if r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_s_mapping_compute @ %def sf_s_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_s_mapping_inverse <>= module subroutine sf_s_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_s_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_s_mapping_inverse <>= module subroutine sf_s_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_s_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: p2 integer :: j if (mapping%power_set) then call map_unit_square_inverse (r(mapping%i), f, p2, mapping%power) else call map_unit_square_inverse (r(mapping%i), f, p2) end if p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = 1 - p2(j) end do end subroutine sf_s_mapping_inverse @ %def sf_s_mapping_inverse @ \subsection{Implementation: resonance pair mapping} This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio, then it maps $p_1$ to itself according to a Breit-Wigner shape, i.e., a flat prior distribution in $p_1$ results in a Breit-Wigner distribution. Mass and width of the BW are rescaled by the energy, thus dimensionless fractions. <>= public :: sf_res_mapping_t <>= type, extends (sf_mapping_t) :: sf_res_mapping_t real(default) :: m = 0 real(default) :: w = 0 contains <> end type sf_res_mapping_t @ %def sf_res_mapping_t @ Output. <>= procedure :: write => sf_res_mapping_write <>= module subroutine sf_res_mapping_write (object, unit) class(sf_res_mapping_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine sf_res_mapping_write <>= module subroutine sf_res_mapping_write (object, unit) class(sf_res_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,', ',F7.5,A)") ": resonance (", object%m, object%w, ")" end subroutine sf_res_mapping_write @ %def sf_res_mapping_write @ Initialize: index pair and dimensionless mass and width parameters. <>= procedure :: init => sf_res_mapping_init <>= module subroutine sf_res_mapping_init (mapping, m, w) class(sf_res_mapping_t), intent(out) :: mapping real(default), intent(in) :: m, w end subroutine sf_res_mapping_init <>= module subroutine sf_res_mapping_init (mapping, m, w) class(sf_res_mapping_t), intent(out) :: mapping real(default), intent(in) :: m, w call mapping%base_init (2) mapping%m = m mapping%w = w end subroutine sf_res_mapping_init @ %def sf_res_mapping_init @ Apply mapping. <>= procedure :: compute => sf_res_mapping_compute <>= module subroutine sf_res_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_res_mapping_compute <>= module subroutine sf_res_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, p2 real(default) :: fbw, f2, p1m integer :: j p2 = p(mapping%i) call map_breit_wigner & (p1m, fbw, p2(1), mapping%m, mapping%w, x_free) call map_unit_square (r2, f2, [p1m, p2(2)]) f = fbw * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_res_mapping_compute @ %def sf_res_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_res_mapping_inverse <>= module subroutine sf_res_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_res_mapping_inverse <>= module subroutine sf_res_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: p2 real(default) :: fbw, f2, p1m call map_unit_square_inverse (r(mapping%i), f2, p2) call map_breit_wigner_inverse & (p2(1), fbw, p1m, mapping%m, mapping%w, x_free) p = r pb= rb p (mapping%i(1)) = p1m pb(mapping%i(1)) = 1 - p1m p (mapping%i(2)) = p2(2) pb(mapping%i(2)) = 1 - p2(2) f = fbw * f2 end subroutine sf_res_mapping_inverse @ %def sf_res_mapping_inverse @ \subsection{Implementation: resonance single mapping} While simpler, this is needed for structure-function setups only in exceptional cases. This maps the unit interval ($r_1$) to itself according to a Breit-Wigner shape, i.e., a flat prior distribution in $r_1$ results in a Breit-Wigner distribution. Mass and width of the BW are rescaled by the energy, thus dimensionless fractions. <>= public :: sf_res_mapping_single_t <>= type, extends (sf_mapping_t) :: sf_res_mapping_single_t real(default) :: m = 0 real(default) :: w = 0 contains <> end type sf_res_mapping_single_t @ %def sf_res_mapping_single_t @ Output. <>= procedure :: write => sf_res_mapping_single_write <>= module subroutine sf_res_mapping_single_write (object, unit) class(sf_res_mapping_single_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine sf_res_mapping_single_write <>= module subroutine sf_res_mapping_single_write (object, unit) class(sf_res_mapping_single_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,', ',F7.5,A)") ": resonance (", object%m, object%w, ")" end subroutine sf_res_mapping_single_write @ %def sf_res_mapping_single_write @ Initialize: single index (!) and dimensionless mass and width parameters. <>= procedure :: init => sf_res_mapping_single_init <>= module subroutine sf_res_mapping_single_init (mapping, m, w) class(sf_res_mapping_single_t), intent(out) :: mapping real(default), intent(in) :: m, w end subroutine sf_res_mapping_single_init <>= module subroutine sf_res_mapping_single_init (mapping, m, w) class(sf_res_mapping_single_t), intent(out) :: mapping real(default), intent(in) :: m, w call mapping%base_init (1) mapping%m = m mapping%w = w end subroutine sf_res_mapping_single_init @ %def sf_res_mapping_single_init @ Apply mapping. <>= procedure :: compute => sf_res_mapping_single_compute <>= module subroutine sf_res_mapping_single_compute & (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_res_mapping_single_compute <>= module subroutine sf_res_mapping_single_compute & (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(1) :: r2, p2 real(default) :: fbw integer :: j p2 = p(mapping%i) call map_breit_wigner & (r2(1), fbw, p2(1), mapping%m, mapping%w, x_free) f = fbw r = p rb= pb r (mapping%i(1)) = r2(1) rb(mapping%i(1)) = 1 - r2(1) end subroutine sf_res_mapping_single_compute @ %def sf_res_mapping_single_compute @ Apply inverse. <>= procedure :: inverse => sf_res_mapping_single_inverse <>= module subroutine sf_res_mapping_single_inverse & (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_res_mapping_single_inverse <>= module subroutine sf_res_mapping_single_inverse & (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(1) :: p2 real(default) :: fbw call map_breit_wigner_inverse & (r(mapping%i(1)), fbw, p2(1), mapping%m, mapping%w, x_free) p = r pb= rb p (mapping%i(1)) = p2(1) pb(mapping%i(1)) = 1 - p2(1) f = fbw end subroutine sf_res_mapping_single_inverse @ %def sf_res_mapping_single_inverse @ \subsection{Implementation: on-shell mapping} This is a degenerate version of the unit-square mapping where the product $r_1r_2$ is constant. This product is given by the rescaled squared mass. We introduce an artificial first parameter $p_1$ to keep the counting, but nothing depends on it. The second parameter is the same $p_2$ as for the standard unit-square mapping for $\alpha=1$, it parameterizes the ratio of $r_1$ and $r_2$. <>= public :: sf_os_mapping_t <>= type, extends (sf_mapping_t) :: sf_os_mapping_t real(default) :: m = 0 real(default) :: lm2 = 0 contains <> end type sf_os_mapping_t @ %def sf_os_mapping_t @ Output. <>= procedure :: write => sf_os_mapping_write <>= module subroutine sf_os_mapping_write (object, unit) class(sf_os_mapping_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine sf_os_mapping_write <>= module subroutine sf_os_mapping_write (object, unit) class(sf_os_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A)") ": on-shell (", object%m, ")" end subroutine sf_os_mapping_write @ %def sf_os_mapping_write @ Initialize: index pair and dimensionless mass parameter. <>= procedure :: init => sf_os_mapping_init <>= module subroutine sf_os_mapping_init (mapping, m) class(sf_os_mapping_t), intent(out) :: mapping real(default), intent(in) :: m end subroutine sf_os_mapping_init <>= module subroutine sf_os_mapping_init (mapping, m) class(sf_os_mapping_t), intent(out) :: mapping real(default), intent(in) :: m call mapping%base_init (2) mapping%m = m mapping%lm2 = abs (2 * log (mapping%m)) end subroutine sf_os_mapping_init @ %def sf_os_mapping_init @ Apply mapping. The [[x_free]] parameter rescales the total energy, which must be accounted for in the enclosed mapping. <>= procedure :: compute => sf_os_mapping_compute <>= module subroutine sf_os_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_os_mapping_compute <>= module subroutine sf_os_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, p2 integer :: j p2 = p(mapping%i) call map_on_shell (r2, f, p2, mapping%lm2, x_free) r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_os_mapping_compute @ %def sf_os_mapping_compute @ Apply inverse. The irrelevant parameter $p_1$ is always set zero. <>= procedure :: inverse => sf_os_mapping_inverse <>= module subroutine sf_os_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_os_mapping_inverse <>= module subroutine sf_os_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: p2, r2 r2 = r(mapping%i) call map_on_shell_inverse (r2, f, p2, mapping%lm2, x_free) p = r pb= rb p (mapping%i(1)) = p2(1) pb(mapping%i(1)) = 1 - p2(1) p (mapping%i(2)) = p2(2) pb(mapping%i(2)) = 1 - p2(2) end subroutine sf_os_mapping_inverse @ %def sf_os_mapping_inverse @ \subsection{Implementation: on-shell single mapping} This is a degenerate version of the unit-interval mapping where the result $r$ is constant. The value is given by the rescaled squared mass. The input parameter $p_1$ is actually ignored, nothing depends on it. <>= public :: sf_os_mapping_single_t <>= type, extends (sf_mapping_t) :: sf_os_mapping_single_t real(default) :: m = 0 real(default) :: lm2 = 0 contains <> end type sf_os_mapping_single_t @ %def sf_os_mapping_single_t @ Output. <>= procedure :: write => sf_os_mapping_single_write <>= module subroutine sf_os_mapping_single_write (object, unit) class(sf_os_mapping_single_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine sf_os_mapping_single_write <>= module subroutine sf_os_mapping_single_write (object, unit) class(sf_os_mapping_single_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A)") ": on-shell (", object%m, ")" end subroutine sf_os_mapping_single_write @ %def sf_os_mapping_single_write @ Initialize: index pair and dimensionless mass parameter. <>= procedure :: init => sf_os_mapping_single_init <>= module subroutine sf_os_mapping_single_init (mapping, m) class(sf_os_mapping_single_t), intent(out) :: mapping real(default), intent(in) :: m end subroutine sf_os_mapping_single_init <>= module subroutine sf_os_mapping_single_init (mapping, m) class(sf_os_mapping_single_t), intent(out) :: mapping real(default), intent(in) :: m call mapping%base_init (1) mapping%m = m mapping%lm2 = abs (2 * log (mapping%m)) end subroutine sf_os_mapping_single_init @ %def sf_os_mapping_single_init @ Apply mapping. The [[x_free]] parameter rescales the total energy, which must be accounted for in the enclosed mapping. <>= procedure :: compute => sf_os_mapping_single_compute <>= module subroutine sf_os_mapping_single_compute & (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_os_mapping_single_compute <>= module subroutine sf_os_mapping_single_compute & (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(1) :: r2, p2 integer :: j p2 = p(mapping%i) call map_on_shell_single (r2, f, p2, mapping%lm2, x_free) r = p rb= pb r (mapping%i(1)) = r2(1) rb(mapping%i(1)) = 1 - r2(1) end subroutine sf_os_mapping_single_compute @ %def sf_os_mapping_single_compute @ Apply inverse. The irrelevant parameter $p_1$ is always set zero. <>= procedure :: inverse => sf_os_mapping_single_inverse <>= module subroutine sf_os_mapping_single_inverse & (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_os_mapping_single_inverse <>= module subroutine sf_os_mapping_single_inverse & (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(1) :: p2, r2 r2 = r(mapping%i) call map_on_shell_single_inverse (r2, f, p2, mapping%lm2, x_free) p = r pb= rb p (mapping%i(1)) = p2(1) pb(mapping%i(1)) = 1 - p2(1) end subroutine sf_os_mapping_single_inverse @ %def sf_os_mapping_single_inverse @ \subsection{Implementation: endpoint mapping} This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio. Furthermore, we enhance the region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$. The enhancement is such that any power-like singularity is caught. This is useful for beamstrahlung spectra. In addition, we allow for a delta-function singularity in $r_1$ and/or $r_2$. The singularity is smeared to an interval of width $\epsilon$. If nonzero, we distinguish the kinematical momentum fractions $r_i$ from effective values $x_i$, which should go into the structure-function evaluation. A bin of width $\epsilon$ in $r$ is mapped to $x=1$ exactly, while the interval $(0,1-\epsilon)$ is mapped to $(0,1)$ in $x$. The Jacobian reflects this distinction, and the logical [[in_peak]] allows for an unambiguous distinction. The delta-peak fraction is used only for the integration self-test. <>= public :: sf_ep_mapping_t <>= type, extends (sf_mapping_t) :: sf_ep_mapping_t real(default) :: a = 1 contains <> end type sf_ep_mapping_t @ %def sf_ep_mapping_t @ Output. <>= procedure :: write => sf_ep_mapping_write <>= module subroutine sf_ep_mapping_write (object, unit) class(sf_ep_mapping_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine sf_ep_mapping_write <>= module subroutine sf_ep_mapping_write (object, unit) class(sf_ep_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,ES12.5,A)") ": endpoint (a =", object%a, ")" end subroutine sf_ep_mapping_write @ %def sf_ep_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_ep_mapping_init <>= module subroutine sf_ep_mapping_init (mapping, a) class(sf_ep_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: a end subroutine sf_ep_mapping_init <>= module subroutine sf_ep_mapping_init (mapping, a) class(sf_ep_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: a call mapping%base_init (2) if (present (a)) mapping%a = a end subroutine sf_ep_mapping_init @ %def sf_ep_mapping_init @ Apply mapping. <>= procedure :: compute => sf_ep_mapping_compute <>= module subroutine sf_ep_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ep_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_ep_mapping_compute <>= module subroutine sf_ep_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ep_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, r2 real(default) :: f1, f2 integer :: j call map_endpoint_1 (px(1), f1, p(mapping%i(1)), mapping%a) call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a) call map_unit_square (r2, f, px) f = f * f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_ep_mapping_compute @ %def sf_ep_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ep_mapping_inverse <>= module subroutine sf_ep_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ep_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_ep_mapping_inverse <>= module subroutine sf_ep_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ep_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, px, p2 real(default) :: f1, f2 integer :: j do j = 1, 2 r2(j) = r(mapping%i(j)) end do call map_unit_square_inverse (r2, f, px) call map_endpoint_inverse_1 (px(1), f1, p2(1), mapping%a) call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a) f = f * f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = 1 - p2(j) end do end subroutine sf_ep_mapping_inverse @ %def sf_ep_mapping_inverse @ \subsection{Implementation: endpoint mapping with resonance} Like the endpoint mapping for $p_2$, but replace the endpoint mapping by a Breit-Wigner mapping for $p_1$. This covers resonance production in the presence of beamstrahlung. If the flag [[resonance]] is unset, we skip the resonance mapping, so the parameter $p_1$ remains equal to $r_1r_2$, as in the standard s-channel mapping. <>= public :: sf_epr_mapping_t <>= type, extends (sf_mapping_t) :: sf_epr_mapping_t real(default) :: a = 1 real(default) :: m = 0 real(default) :: w = 0 logical :: resonance = .true. contains <> end type sf_epr_mapping_t @ %def sf_epr_mapping_t @ Output. <>= procedure :: write => sf_epr_mapping_write <>= module subroutine sf_epr_mapping_write (object, unit) class(sf_epr_mapping_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine sf_epr_mapping_write <>= module subroutine sf_epr_mapping_write (object, unit) class(sf_epr_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if if (object%resonance) then write (u, "(A,F7.5,A,F7.5,', ',F7.5,A)") ": ep/res (a = ", object%a, & " | ", object%m, object%w, ")" else write (u, "(A,F7.5,A)") ": ep/nores (a = ", object%a, ")" end if end subroutine sf_epr_mapping_write @ %def sf_epr_mapping_write @ Initialize: if mass and width are not given, we initialize a non-resonant version of the mapping. <>= procedure :: init => sf_epr_mapping_init <>= module subroutine sf_epr_mapping_init (mapping, a, m, w) class(sf_epr_mapping_t), intent(out) :: mapping real(default), intent(in) :: a real(default), intent(in), optional :: m, w end subroutine sf_epr_mapping_init <>= module subroutine sf_epr_mapping_init (mapping, a, m, w) class(sf_epr_mapping_t), intent(out) :: mapping real(default), intent(in) :: a real(default), intent(in), optional :: m, w call mapping%base_init (2) mapping%a = a if (present (m) .and. present (w)) then mapping%m = m mapping%w = w else mapping%resonance = .false. end if end subroutine sf_epr_mapping_init @ %def sf_epr_mapping_init @ Apply mapping. <>= procedure :: compute => sf_epr_mapping_compute <>= module subroutine sf_epr_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_epr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_epr_mapping_compute <>= module subroutine sf_epr_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_epr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, r2 real(default) :: f1, f2 integer :: j if (mapping%resonance) then call map_breit_wigner & (px(1), f1, p(mapping%i(1)), mapping%m, mapping%w, x_free) else px(1) = p(mapping%i(1)) f1 = 1 end if call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a) call map_unit_square (r2, f, px) f = f * f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_epr_mapping_compute @ %def sf_epr_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_epr_mapping_inverse <>= module subroutine sf_epr_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_epr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_epr_mapping_inverse <>= module subroutine sf_epr_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_epr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, p2 real(default) :: f1, f2 integer :: j call map_unit_square_inverse (r(mapping%i), f, px) if (mapping%resonance) then call map_breit_wigner_inverse & (px(1), f1, p2(1), mapping%m, mapping%w, x_free) else p2(1) = px(1) f1 = 1 end if call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a) f = f * f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = 1 - p2(j) end do end subroutine sf_epr_mapping_inverse @ %def sf_epr_mapping_inverse @ \subsection{Implementation: endpoint mapping for on-shell particle} Analogous to the resonance mapping, but the $p_1$ input is ignored altogether. This covers on-shell particle production in the presence of beamstrahlung. <>= public :: sf_epo_mapping_t <>= type, extends (sf_mapping_t) :: sf_epo_mapping_t real(default) :: a = 1 real(default) :: m = 0 real(default) :: lm2 = 0 contains <> end type sf_epo_mapping_t @ %def sf_epo_mapping_t @ Output. <>= procedure :: write => sf_epo_mapping_write <>= module subroutine sf_epo_mapping_write (object, unit) class(sf_epo_mapping_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine sf_epo_mapping_write <>= module subroutine sf_epo_mapping_write (object, unit) class(sf_epo_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A,F7.5,A)") ": ep/on-shell (a = ", object%a, & " | ", object%m, ")" end subroutine sf_epo_mapping_write @ %def sf_epo_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_epo_mapping_init <>= module subroutine sf_epo_mapping_init (mapping, a, m) class(sf_epo_mapping_t), intent(out) :: mapping real(default), intent(in) :: a, m end subroutine sf_epo_mapping_init <>= module subroutine sf_epo_mapping_init (mapping, a, m) class(sf_epo_mapping_t), intent(out) :: mapping real(default), intent(in) :: a, m call mapping%base_init (2) mapping%a = a mapping%m = m mapping%lm2 = abs (2 * log (mapping%m)) end subroutine sf_epo_mapping_init @ %def sf_epo_mapping_init @ Apply mapping. <>= procedure :: compute => sf_epo_mapping_compute <>= module subroutine sf_epo_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_epo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_epo_mapping_compute <>= module subroutine sf_epo_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_epo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, r2 real(default) :: f2 integer :: j px(1) = 0 call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a) call map_on_shell (r2, f, px, mapping%lm2) f = f * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_epo_mapping_compute @ %def sf_epo_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_epo_mapping_inverse <>= module subroutine sf_epo_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_epo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_epo_mapping_inverse <>= module subroutine sf_epo_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_epo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, p2 real(default) :: f2 integer :: j call map_on_shell_inverse (r(mapping%i), f, px, mapping%lm2) p2(1) = 0 call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a) f = f * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = 1 - p2(j) end do end subroutine sf_epo_mapping_inverse @ %def sf_epo_mapping_inverse @ \subsection{Implementation: ISR endpoint mapping} Similar to the endpoint mapping above: This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio. Furthermore, we enhance the region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$. The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is flattened. This would be easy in one dimension, but becomes nontrivial in two dimensions. <>= public :: sf_ip_mapping_t <>= type, extends (sf_mapping_t) :: sf_ip_mapping_t real(default) :: eps = 0 contains <> end type sf_ip_mapping_t @ %def sf_ip_mapping_t @ Output. <>= procedure :: write => sf_ip_mapping_write <>= module subroutine sf_ip_mapping_write (object, unit) class(sf_ip_mapping_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine sf_ip_mapping_write <>= module subroutine sf_ip_mapping_write (object, unit) class(sf_ip_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,ES12.5,A)") ": isr (eps =", object%eps, ")" end subroutine sf_ip_mapping_write @ %def sf_ip_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_ip_mapping_init <>= module subroutine sf_ip_mapping_init (mapping, eps) class(sf_ip_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: eps end subroutine sf_ip_mapping_init <>= module subroutine sf_ip_mapping_init (mapping, eps) class(sf_ip_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: eps call mapping%base_init (2) if (present (eps)) mapping%eps = eps if (mapping%eps <= 0) & call msg_fatal ("ISR mapping: regulator epsilon must not be zero") end subroutine sf_ip_mapping_init @ %def sf_ip_mapping_init @ Apply mapping. <>= procedure :: compute => sf_ip_mapping_compute <>= module subroutine sf_ip_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ip_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_ip_mapping_compute <>= module subroutine sf_ip_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ip_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, pxb, r2, r2b real(default) :: f1, f2, xb, y, yb integer :: j call map_power_1 (xb, f1, pb(mapping%i(1)), 2 * mapping%eps) call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps) px(1) = 1 - xb pxb(1) = xb px(2) = y pxb(2) = yb call map_unit_square_prec (r2, r2b, f, px, pxb) f = f * f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2 (j) rb(mapping%i(j)) = r2b(j) end do end subroutine sf_ip_mapping_compute @ %def sf_ip_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ip_mapping_inverse <>= module subroutine sf_ip_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ip_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_ip_mapping_inverse <>= module subroutine sf_ip_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ip_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b real(default) :: f1, f2, xb, y, yb integer :: j do j = 1, 2 r2 (j) = r (mapping%i(j)) r2b(j) = rb(mapping%i(j)) end do call map_unit_square_inverse_prec (r2, r2b, f, px, pxb) xb = pxb(1) if (px(1) > 0) then y = px(2) yb = pxb(2) else y = 0.5_default yb = 0.5_default end if call map_power_inverse_1 (xb, f1, p2b(1), 2 * mapping%eps) call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps) p2 = 1 - p2b f = f * f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = p2b(j) end do end subroutine sf_ip_mapping_inverse @ %def sf_ip_mapping_inverse @ \subsection{Implementation: ISR endpoint mapping, resonant} Similar to the endpoint mapping above: This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio. Furthermore, we enhance the region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$. The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is flattened. This would be easy in one dimension, but becomes nontrivial in two dimensions. The resonance can be turned off by the flag [[resonance]]. <>= public :: sf_ipr_mapping_t <>= type, extends (sf_mapping_t) :: sf_ipr_mapping_t real(default) :: eps = 0 real(default) :: m = 0 real(default) :: w = 0 logical :: resonance = .true. contains <> end type sf_ipr_mapping_t @ %def sf_ipr_mapping_t @ Output. <>= procedure :: write => sf_ipr_mapping_write <>= module subroutine sf_ipr_mapping_write (object, unit) class(sf_ipr_mapping_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine sf_ipr_mapping_write <>= module subroutine sf_ipr_mapping_write (object, unit) class(sf_ipr_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if if (object%resonance) then write (u, "(A,F7.5,A,F7.5,', ',F7.5,A)") ": isr/res (eps = ", & object%eps, " | ", object%m, object%w, ")" else write (u, "(A,F7.5,A)") ": isr/res (eps = ", object%eps, ")" end if end subroutine sf_ipr_mapping_write @ %def sf_ipr_mapping_write @ Initialize: <>= procedure :: init => sf_ipr_mapping_init <>= module subroutine sf_ipr_mapping_init (mapping, eps, m, w) class(sf_ipr_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: eps, m, w end subroutine sf_ipr_mapping_init <>= module subroutine sf_ipr_mapping_init (mapping, eps, m, w) class(sf_ipr_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: eps, m, w call mapping%base_init (2) if (present (eps)) mapping%eps = eps if (mapping%eps <= 0) & call msg_fatal ("ISR mapping: regulator epsilon must not be zero") if (present (m) .and. present (w)) then mapping%m = m mapping%w = w else mapping%resonance = .false. end if end subroutine sf_ipr_mapping_init @ %def sf_ipr_mapping_init @ Apply mapping. <>= procedure :: compute => sf_ipr_mapping_compute <>= module subroutine sf_ipr_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ipr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_ipr_mapping_compute <>= module subroutine sf_ipr_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ipr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, pxb, r2, r2b real(default) :: f1, f2, y, yb integer :: j if (mapping%resonance) then call map_breit_wigner & (px(1), f1, p(mapping%i(1)), mapping%m, mapping%w, x_free) else px(1) = p(mapping%i(1)) f1 = 1 end if call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps) pxb(1) = 1 - px(1) px(2) = y pxb(2) = yb call map_unit_square_prec (r2, r2b, f, px, pxb) f = f * f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2 (j) rb(mapping%i(j)) = r2b(j) end do end subroutine sf_ipr_mapping_compute @ %def sf_ipr_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ipr_mapping_inverse <>= module subroutine sf_ipr_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ipr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_ipr_mapping_inverse <>= module subroutine sf_ipr_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ipr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b real(default) :: f1, f2, y, yb integer :: j do j = 1, 2 r2 (j) = r (mapping%i(j)) r2b(j) = rb(mapping%i(j)) end do call map_unit_square_inverse_prec (r2, r2b, f, px, pxb) if (px(1) > 0) then y = px(2) yb = pxb(2) else y = 0.5_default yb = 0.5_default end if if (mapping%resonance) then call map_breit_wigner_inverse & (px(1), f1, p2(1), mapping%m, mapping%w, x_free) else p2(1) = px(1) f1 = 1 end if call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps) p2b(1) = 1 - p2(1) p2 (2) = 1 - p2b(2) f = f * f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = p2b(j) end do end subroutine sf_ipr_mapping_inverse @ %def sf_ipr_mapping_inverse @ \subsection{Implementation: ISR on-shell mapping} Similar to the endpoint mapping above: This maps the unit square ($r_1,r_2$) such that $p_1$ is ignored while the product $r_1r_2$ is constant. $p_2$ is related to the ratio. Furthermore, we enhance the region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$. The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is flattened. This would be easy in one dimension, but becomes nontrivial in two dimensions. <>= public :: sf_ipo_mapping_t <>= type, extends (sf_mapping_t) :: sf_ipo_mapping_t real(default) :: eps = 0 real(default) :: m = 0 contains <> end type sf_ipo_mapping_t @ %def sf_ipo_mapping_t @ Output. <>= procedure :: write => sf_ipo_mapping_write <>= module subroutine sf_ipo_mapping_write (object, unit) class(sf_ipo_mapping_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine sf_ipo_mapping_write <>= module subroutine sf_ipo_mapping_write (object, unit) class(sf_ipo_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A,F7.5,A)") ": isr/os (eps = ", object%eps, & " | ", object%m, ")" end subroutine sf_ipo_mapping_write @ %def sf_ipo_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_ipo_mapping_init <>= module subroutine sf_ipo_mapping_init (mapping, eps, m) class(sf_ipo_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: eps, m end subroutine sf_ipo_mapping_init <>= module subroutine sf_ipo_mapping_init (mapping, eps, m) class(sf_ipo_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: eps, m call mapping%base_init (2) if (present (eps)) mapping%eps = eps if (mapping%eps <= 0) & call msg_fatal ("ISR mapping: regulator epsilon must not be zero") mapping%m = m end subroutine sf_ipo_mapping_init @ %def sf_ipo_mapping_init @ Apply mapping. <>= procedure :: compute => sf_ipo_mapping_compute <>= module subroutine sf_ipo_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ipo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_ipo_mapping_compute <>= module subroutine sf_ipo_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ipo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, pxb, r2, r2b real(default) :: f1, f2, y, yb integer :: j call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps) px(1) = mapping%m ** 2 if (present (x_free)) px(1) = px(1) / x_free pxb(1) = 1 - px(1) px(2) = y pxb(2) = yb call map_unit_square_prec (r2, r2b, f1, px, pxb) f = f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2 (j) rb(mapping%i(j)) = r2b(j) end do end subroutine sf_ipo_mapping_compute @ %def sf_ipo_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ipo_mapping_inverse <>= module subroutine sf_ipo_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ipo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_ipo_mapping_inverse <>= module subroutine sf_ipo_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ipo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b real(default) :: f1, f2, y, yb integer :: j do j = 1, 2 r2 (j) = r (mapping%i(j)) r2b(j) = rb(mapping%i(j)) end do call map_unit_square_inverse_prec (r2, r2b, f1, px, pxb) y = px(2) yb = pxb(2) call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps) p2(1) = 0 p2b(1)= 1 p2(2) = 1 - p2b(2) f = f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = p2b(j) end do end subroutine sf_ipo_mapping_inverse @ %def sf_ipo_mapping_inverse @ \subsection{Implementation: Endpoint + ISR power mapping} This is a combination of endpoint (i.e., beamstrahlung) and ISR power mapping. The first two parameters apply to the beamstrahlung spectrum, the last two to the ISR function for the first and second beam, respectively. <>= public :: sf_ei_mapping_t <>= type, extends (sf_mapping_t) :: sf_ei_mapping_t type(sf_ep_mapping_t) :: ep type(sf_ip_mapping_t) :: ip contains <> end type sf_ei_mapping_t @ %def sf_ei_mapping_t @ Output. <>= procedure :: write => sf_ei_mapping_write <>= module subroutine sf_ei_mapping_write (object, unit) class(sf_ei_mapping_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine sf_ei_mapping_write <>= module subroutine sf_ei_mapping_write (object, unit) class(sf_ei_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,3(',',I0),')')", advance="no") object%i end if write (u, "(A,ES12.5,A,ES12.5,A)") ": ep/isr (a =", object%ep%a, & ", eps =", object%ip%eps, ")" end subroutine sf_ei_mapping_write @ %def sf_ei_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_ei_mapping_init <>= module subroutine sf_ei_mapping_init (mapping, a, eps) class(sf_ei_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: a, eps end subroutine sf_ei_mapping_init <>= module subroutine sf_ei_mapping_init (mapping, a, eps) class(sf_ei_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: a, eps call mapping%base_init (4) call mapping%ep%init (a) call mapping%ip%init (eps) end subroutine sf_ei_mapping_init @ %def sf_ei_mapping_init @ Set an index value. We should communicate the appropriate indices to the enclosed sub-mappings, therefore override the method. <>= procedure :: set_index => sf_ei_mapping_set_index <>= module subroutine sf_ei_mapping_set_index (mapping, j, i) class(sf_ei_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i end subroutine sf_ei_mapping_set_index <>= module subroutine sf_ei_mapping_set_index (mapping, j, i) class(sf_ei_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i mapping%i(j) = i select case (j) case (1:2); call mapping%ep%set_index (j, i) case (3:4); call mapping%ip%set_index (j-2, i) end select end subroutine sf_ei_mapping_set_index @ %def sf_mapping_set_index @ Apply mapping. Now, the beamstrahlung and ISR mappings are independent of each other. The parameter subsets that are actually used should not overlap. The Jacobians are multiplied. <>= procedure :: compute => sf_ei_mapping_compute <>= module subroutine sf_ei_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ei_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_ei_mapping_compute <>= module subroutine sf_ei_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ei_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: q, qb real(default) :: f1, f2 call mapping%ep%compute (q, qb, f1, p, pb, x_free) call mapping%ip%compute (r, rb, f2, q, qb, x_free) f = f1 * f2 end subroutine sf_ei_mapping_compute @ %def sf_ei_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ei_mapping_inverse <>= module subroutine sf_ei_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ei_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_ei_mapping_inverse <>= module subroutine sf_ei_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ei_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: q, qb real(default) :: f1, f2 call mapping%ip%inverse (r, rb, f2, q, qb, x_free) call mapping%ep%inverse (q, qb, f1, p, pb, x_free) f = f1 * f2 end subroutine sf_ei_mapping_inverse @ %def sf_ei_mapping_inverse @ \subsection{Implementation: Endpoint + ISR + resonance} This is a combination of endpoint (i.e., beamstrahlung) and ISR power mapping, adapted for an s-channel resonance. The first two internal parameters apply to the beamstrahlung spectrum, the last two to the ISR function for the first and second beam, respectively. The first and third parameters are the result of an overall resonance mapping, so on the outside, the first parameter is the total momentum fraction, the third one describes the distribution between beamstrahlung and ISR. <>= public :: sf_eir_mapping_t <>= type, extends (sf_mapping_t) :: sf_eir_mapping_t type(sf_res_mapping_t) :: res type(sf_epr_mapping_t) :: ep type(sf_ipr_mapping_t) :: ip contains <> end type sf_eir_mapping_t @ %def sf_eir_mapping_t @ Output. <>= procedure :: write => sf_eir_mapping_write <>= module subroutine sf_eir_mapping_write (object, unit) class(sf_eir_mapping_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine sf_eir_mapping_write <>= module subroutine sf_eir_mapping_write (object, unit) class(sf_eir_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,3(',',I0),')')", advance="no") object%i end if write (u, "(A,F7.5,A,F7.5,A,F7.5,', ',F7.5,A)") & ": ep/isr/res (a =", object%ep%a, & ", eps =", object%ip%eps, " | ", object%res%m, object%res%w, ")" end subroutine sf_eir_mapping_write @ %def sf_eir_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_eir_mapping_init <>= module subroutine sf_eir_mapping_init (mapping, a, eps, m, w) class(sf_eir_mapping_t), intent(out) :: mapping real(default), intent(in) :: a, eps, m, w end subroutine sf_eir_mapping_init <>= module subroutine sf_eir_mapping_init (mapping, a, eps, m, w) class(sf_eir_mapping_t), intent(out) :: mapping real(default), intent(in) :: a, eps, m, w call mapping%base_init (4) call mapping%res%init (m, w) call mapping%ep%init (a) call mapping%ip%init (eps) end subroutine sf_eir_mapping_init @ %def sf_eir_mapping_init @ Set an index value. We should communicate the appropriate indices to the enclosed sub-mappings, therefore override the method. <>= procedure :: set_index => sf_eir_mapping_set_index <>= module subroutine sf_eir_mapping_set_index (mapping, j, i) class(sf_eir_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i end subroutine sf_eir_mapping_set_index <>= module subroutine sf_eir_mapping_set_index (mapping, j, i) class(sf_eir_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i mapping%i(j) = i select case (j) case (1); call mapping%res%set_index (1, i) case (3); call mapping%res%set_index (2, i) end select select case (j) case (1:2); call mapping%ep%set_index (j, i) case (3:4); call mapping%ip%set_index (j-2, i) end select end subroutine sf_eir_mapping_set_index @ %def sf_mapping_set_index @ Apply mapping. Now, the beamstrahlung and ISR mappings are independent of each other. The parameter subsets that are actually used should not overlap. The Jacobians are multiplied. <>= procedure :: compute => sf_eir_mapping_compute <>= module subroutine sf_eir_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_eir_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_eir_mapping_compute <>= module subroutine sf_eir_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_eir_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: px, pxb, q, qb real(default) :: f0, f1, f2 call mapping%res%compute (px, pxb, f0, p, pb, x_free) call mapping%ep%compute (q, qb, f1, px, pxb, x_free) call mapping%ip%compute (r, rb, f2, q, qb, x_free) f = f0 * f1 * f2 end subroutine sf_eir_mapping_compute @ %def sf_eir_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_eir_mapping_inverse <>= module subroutine sf_eir_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_eir_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_eir_mapping_inverse <>= module subroutine sf_eir_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_eir_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: px, pxb, q, qb real(default) :: f0, f1, f2 call mapping%ip%inverse (r, rb, f2, q, qb, x_free) call mapping%ep%inverse (q, qb, f1, px, pxb, x_free) call mapping%res%inverse (px, pxb, f0, p, pb, x_free) f = f0 * f1 * f2 end subroutine sf_eir_mapping_inverse @ %def sf_eir_mapping_inverse @ \subsection{Implementation: Endpoint + ISR power mapping, on-shell} This is a combination of endpoint (i.e., beamstrahlung) and ISR power mapping. The first two parameters apply to the beamstrahlung spectrum, the last two to the ISR function for the first and second beam, respectively. On top of that, we map the first and third parameter such that the product is constant. From the outside, the first parameter is irrelevant while the third parameter describes the distribution of energy (loss) among beamstrahlung and ISR. <>= public :: sf_eio_mapping_t <>= type, extends (sf_mapping_t) :: sf_eio_mapping_t type(sf_os_mapping_t) :: os type(sf_epr_mapping_t) :: ep type(sf_ipr_mapping_t) :: ip contains <> end type sf_eio_mapping_t @ %def sf_eio_mapping_t @ Output. <>= procedure :: write => sf_eio_mapping_write <>= module subroutine sf_eio_mapping_write (object, unit) class(sf_eio_mapping_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine sf_eio_mapping_write <>= module subroutine sf_eio_mapping_write (object, unit) class(sf_eio_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,3(',',I0),')')", advance="no") object%i end if write (u, "(A,F7.5,A,F7.5,A,F7.5,A)") ": ep/isr/os (a =", object%ep%a, & ", eps =", object%ip%eps, " | ", object%os%m, ")" end subroutine sf_eio_mapping_write @ %def sf_eio_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_eio_mapping_init <>= module subroutine sf_eio_mapping_init (mapping, a, eps, m) class(sf_eio_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: a, eps, m end subroutine sf_eio_mapping_init <>= module subroutine sf_eio_mapping_init (mapping, a, eps, m) class(sf_eio_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: a, eps, m call mapping%base_init (4) call mapping%os%init (m) call mapping%ep%init (a) call mapping%ip%init (eps) end subroutine sf_eio_mapping_init @ %def sf_eio_mapping_init @ Set an index value. We should communicate the appropriate indices to the enclosed sub-mappings, therefore override the method. <>= procedure :: set_index => sf_eio_mapping_set_index <>= module subroutine sf_eio_mapping_set_index (mapping, j, i) class(sf_eio_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i end subroutine sf_eio_mapping_set_index <>= module subroutine sf_eio_mapping_set_index (mapping, j, i) class(sf_eio_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i mapping%i(j) = i select case (j) case (1); call mapping%os%set_index (1, i) case (3); call mapping%os%set_index (2, i) end select select case (j) case (1:2); call mapping%ep%set_index (j, i) case (3:4); call mapping%ip%set_index (j-2, i) end select end subroutine sf_eio_mapping_set_index @ %def sf_mapping_set_index @ Apply mapping. Now, the beamstrahlung and ISR mappings are independent of each other. The parameter subsets that are actually used should not overlap. The Jacobians are multiplied. <>= procedure :: compute => sf_eio_mapping_compute <>= module subroutine sf_eio_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_eio_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_eio_mapping_compute <>= module subroutine sf_eio_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_eio_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: px, pxb, q, qb real(default) :: f0, f1, f2 call mapping%os%compute (px, pxb, f0, p, pb, x_free) call mapping%ep%compute (q, qb, f1, px, pxb, x_free) call mapping%ip%compute (r, rb, f2, q, qb, x_free) f = f0 * f1 * f2 end subroutine sf_eio_mapping_compute @ %def sf_eio_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_eio_mapping_inverse <>= module subroutine sf_eio_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_eio_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_eio_mapping_inverse <>= module subroutine sf_eio_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_eio_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: px, pxb, q, qb real(default) :: f0, f1, f2 call mapping%ip%inverse (r, rb, f2, q, qb, x_free) call mapping%ep%inverse (q, qb, f1, px, pxb, x_free) call mapping%os%inverse (px, pxb, f0, p, pb, x_free) f = f0 * f1 * f2 end subroutine sf_eio_mapping_inverse @ %def sf_eio_mapping_inverse @ \subsection{Basic formulas} \subsubsection{Standard mapping of the unit square} This mapping of the unit square is appropriate in particular for structure functions which are concentrated at the lower end. Instead of a rectangular grid, one set of grid lines corresponds to constant parton c.m. energy. The other set is chosen such that the jacobian is only mildly singular ($\ln x$ which is zero at $x=1$), corresponding to an initial concentration of sampling points at the maximum energy. If [[power]] is greater than one (the default), points are also concentrated at the lower end. The formula is ([[power]]=$\alpha$): \begin{align} r_1 &= (p_1 ^ {p_2})^\alpha \\ r_2 &= (p_1 ^ {1 - p_2})^\alpha\\ f &= \alpha^2 p_1 ^ {\alpha - 1} |\log p_1| \end{align} and for the default case $\alpha=1$: \begin{align} r_1 &= p_1 ^ {p_2} \\ r_2 &= p_1 ^ {1 - p_2} \\ f &= |\log p_1| \end{align} <>= subroutine map_unit_square (r, factor, p, power) real(default), dimension(2), intent(out) :: r real(default), intent(out) :: factor real(default), dimension(2), intent(in) :: p real(default), intent(in), optional :: power real(default) :: xx, yy factor = 1 xx = p(1) yy = p(2) if (present(power)) then if (p(1) > 0 .and. power > 1) then xx = p(1)**power factor = factor * power * xx / p(1) end if end if if (.not. vanishes (xx)) then r(1) = xx ** yy r(2) = xx / r(1) factor = factor * abs (log (xx)) else r = 0 end if end subroutine map_unit_square @ %def map_unit_square @ This is the inverse mapping. <>= subroutine map_unit_square_inverse (r, factor, p, power) real(kind=default), dimension(2), intent(in) :: r real(kind=default), intent(out) :: factor real(kind=default), dimension(2), intent(out) :: p real(kind=default), intent(in), optional :: power real(kind=default) :: lg, xx, yy factor = 1 xx = r(1) * r(2) if (.not. vanishes (xx)) then lg = log (xx) if (.not. vanishes (lg)) then yy = log (r(1)) / lg else yy = 0 end if p(2) = yy factor = factor * abs (lg) if (present(power)) then p(1) = xx**(1._default/power) factor = factor * power * xx / p(1) else p(1) = xx end if else p = 0 end if end subroutine map_unit_square_inverse @ %def map_unit_square_inverse @ \subsubsection{Precise mapping of the unit square} A more precise version (with unit power parameter). This version should be numerically stable near $x=1$ and $y=0,1$. The formulas are again \begin{equation} r_1 = p_1^{p_2}, \qquad r_2 = p_1^{\bar p_2}, \qquad f = - \log p_1 \end{equation} but we compute both $r_i$ and $\bar r_i$ simultaneously and make direct use of both $p_i$ and $\bar p_i$ as appropriate. <>= subroutine map_unit_square_prec (r, rb, factor, p, pb) real(default), dimension(2), intent(out) :: r real(default), dimension(2), intent(out) :: rb real(default), intent(out) :: factor real(default), dimension(2), intent(in) :: p real(default), dimension(2), intent(in) :: pb if (p(1) > 0.5_default) then call compute_prec_xy_1 (r(1), rb(1), p(1), pb(1), p (2)) call compute_prec_xy_1 (r(2), rb(2), p(1), pb(1), pb(2)) factor = - log_prec (p(1), pb(1)) else if (.not. vanishes (p(1))) then call compute_prec_xy_0 (r(1), rb(1), p(1), pb(1), p (2)) call compute_prec_xy_0 (r(2), rb(2), p(1), pb(1), pb(2)) factor = - log_prec (p(1), pb(1)) else r = 0 rb = 1 factor = 0 end if end subroutine map_unit_square_prec @ %def map_unit_square_prec @ This is the inverse mapping. <>= subroutine map_unit_square_inverse_prec (r, rb, factor, p, pb) real(default), dimension(2), intent(in) :: r real(default), dimension(2), intent(in) :: rb real(default), intent(out) :: factor real(default), dimension(2), intent(out) :: p real(default), dimension(2), intent(out) :: pb call inverse_prec_x (r, rb, p(1), pb(1)) if (all (r > 0)) then if (rb(1) < rb(2)) then call inverse_prec_y (r, rb, p(2), pb(2)) else call inverse_prec_y ([r(2),r(1)], [rb(2),rb(1)], pb(2), p(2)) end if factor = - log_prec (p(1), pb(1)) else p(1) = 0 pb(1) = 1 p(2) = 0.5_default pb(2) = 0.5_default factor = 0 end if end subroutine map_unit_square_inverse_prec @ %def map_unit_square_prec_inverse @ This is an auxiliary function: evaluate the expression $\bar z = 1 - x^y$ in a numerically stable way. Instabilities occur for $y=0$ and $x=1$. The idea is to replace the bracket by the first terms of its Taylor expansion around $x=1$ (read $\bar x\equiv 1 -x$) \begin{equation} 1 - x^y = y\bar x\left(1 + \frac12(1-y)\bar x + \frac16(2-y)(1-y)\bar x^2\right) \end{equation} whenever this is the better approximation. Actually, the relative numerical error of the exact formula is about $\eta/(y\bar x)$ where $\eta$ is given by [[epsilon(KIND)]] in Fortran. The relative error of the approximation is better than the last included term divided by $(y\bar x)$. The first subroutine computes $z$ and $\bar z$ near $x=1$ where $\log x$ should be expanded, the second one near $x=0$ where $\log x$ can be kept. <>= subroutine compute_prec_xy_1 (z, zb, x, xb, y) real(default), intent(out) :: z, zb real(default), intent(in) :: x, xb, y real(default) :: a1, a2, a3 a1 = y * xb a2 = a1 * (1 - y) * xb / 2 a3 = a2 * (2 - y) * xb / 3 if (abs (a3) < epsilon (a3)) then zb = a1 + a2 + a3 z = 1 - zb else z = x ** y zb = 1 - z end if end subroutine compute_prec_xy_1 subroutine compute_prec_xy_0 (z, zb, x, xb, y) real(default), intent(out) :: z, zb real(default), intent(in) :: x, xb, y real(default) :: a1, a2, a3, lx lx = -log (x) a1 = y * lx a2 = a1 * y * lx / 2 a3 = a2 * y * lx / 3 if (abs (a3) < epsilon (a3)) then zb = a1 + a2 + a3 z = 1 - zb else z = x ** y zb = 1 - z end if end subroutine compute_prec_xy_0 @ %def compute_prec_xy_1 @ %def compute_prec_xy_0 @ For the inverse calculation, we evaluate $x=r_1r_2$ in a stable way. Since it is just a polynomial, the expansion near $x=1$ is analytically exact, and we don't need to choose based on precision. <>= subroutine inverse_prec_x (r, rb, x, xb) real(default), dimension(2), intent(in) :: r, rb real(default), intent(out) :: x, xb real(default) :: a0, a1 a0 = rb(1) + rb(2) a1 = rb(1) * rb(2) if (a0 > 0.5_default) then xb = a0 - a1 x = 1 - xb else x = r(1) * r(2) xb = 1 - x end if end subroutine inverse_prec_x @ %def inverse_prec_x @ The inverse calculation for the relative momentum fraction \begin{equation} y = \frac{1}{1 + \frac{\log{r_2}}{\log{r_1}}} \end{equation} is slightly more complicated. We should take the precise form of the logarithm, so we are safe near $r_i=1$. A series expansion is required if $r_1\ll r_2$, since then $y$ becomes small. (We assume $r_1>= subroutine inverse_prec_y (r, rb, y, yb) real(default), dimension(2), intent(in) :: r, rb real(default), intent(out) :: y, yb real(default) :: log1, log2, a1, a2, a3 log1 = log_prec (r(1), rb(1)) log2 = log_prec (r(2), rb(2)) if (abs (log2**3) < epsilon (one)) then if (abs(log1) < epsilon (one)) then y = zero else y = one / (one + log2 / log1) end if if (abs(log2) < epsilon (one)) then yb = zero else yb = one / (one + log1 / log2) end if return end if a1 = - rb(1) / log2 a2 = - rb(1) ** 2 * (one / log2**2 + one / (2 * log2)) a3 = - rb(1) ** 3 * (one / log2**3 + one / log2**2 + one/(3 * log2)) if (abs (a3) < epsilon (a3)) then y = a1 + a2 + a3 yb = one - y else y = one / (one + log2 / log1) yb = one / (one + log1 / log2) end if end subroutine inverse_prec_y @ %def inverse_prec_y @ \subsubsection{Mapping for on-shell s-channel} The limiting case, if the product $r_1r_2$ is fixed for on-shell production. The parameter $p_1$ is ignored. In the inverse mapping, it is returned zero. The parameter [[x_free]], if present, rescales the total energy. If it is less than one, the rescaled mass parameter $m^2$ should be increased accordingly. Public for access in unit test. <>= public :: map_on_shell public :: map_on_shell_inverse <>= module subroutine map_on_shell (r, factor, p, lm2, x_free) real(default), dimension(2), intent(out) :: r real(default), intent(out) :: factor real(default), dimension(2), intent(in) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free end subroutine map_on_shell module subroutine map_on_shell_inverse (r, factor, p, lm2, x_free) real(default), dimension(2), intent(in) :: r real(default), intent(out) :: factor real(default), dimension(2), intent(out) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free end subroutine map_on_shell_inverse <>= module subroutine map_on_shell (r, factor, p, lm2, x_free) real(default), dimension(2), intent(out) :: r real(default), intent(out) :: factor real(default), dimension(2), intent(in) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free real(default) :: lx lx = lm2; if (present (x_free)) lx = lx + log (x_free) r(1) = exp (- p(2) * lx) r(2) = exp (- (1 - p(2)) * lx) factor = lx end subroutine map_on_shell module subroutine map_on_shell_inverse (r, factor, p, lm2, x_free) real(default), dimension(2), intent(in) :: r real(default), intent(out) :: factor real(default), dimension(2), intent(out) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free real(default) :: lx lx = lm2; if (present (x_free)) lx = lx + log (x_free) p(1) = 0 p(2) = abs (log (r(1))) / lx factor = lx end subroutine map_on_shell_inverse @ %def map_on_shell @ %def map_on_shell_inverse @ \subsubsection{Mapping for on-shell s-channel, single parameter} This is a pseudo-mapping which applies if there is actually just one parameter [[p]]. The output parameter [[r]] is fixed for on-shell production. The lone parameter $p_1$ is ignored. In the inverse mapping, it is returned zero. The parameter [[x_free]], if present, rescales the total energy. If it is less than one, the rescaled mass parameter $m^2$ should be increased accordingly. Public for access in unit test. <>= public :: map_on_shell_single public :: map_on_shell_single_inverse <>= module subroutine map_on_shell_single (r, factor, p, lm2, x_free) real(default), dimension(1), intent(out) :: r real(default), intent(out) :: factor real(default), dimension(1), intent(in) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free end subroutine map_on_shell_single module subroutine map_on_shell_single_inverse (r, factor, p, lm2, x_free) real(default), dimension(1), intent(in) :: r real(default), intent(out) :: factor real(default), dimension(1), intent(out) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free end subroutine map_on_shell_single_inverse <>= module subroutine map_on_shell_single (r, factor, p, lm2, x_free) real(default), dimension(1), intent(out) :: r real(default), intent(out) :: factor real(default), dimension(1), intent(in) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free real(default) :: lx lx = lm2; if (present (x_free)) lx = lx + log (x_free) r(1) = exp (- lx) factor = 1 end subroutine map_on_shell_single module subroutine map_on_shell_single_inverse (r, factor, p, lm2, x_free) real(default), dimension(1), intent(in) :: r real(default), intent(out) :: factor real(default), dimension(1), intent(out) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free real(default) :: lx lx = lm2; if (present (x_free)) lx = lx + log (x_free) p(1) = 0 factor = 1 end subroutine map_on_shell_single_inverse @ %def map_on_shell_single @ %def map_on_shell_single_inverse @ \subsubsection{Mapping for a Breit-Wigner resonance} This is the standard Breit-Wigner mapping. We apply it to a single variable, independently of or in addition to a unit-square mapping. We assume here that the limits for the variable are 0 and 1, and that the mass $m$ and width $w$ are rescaled appropriately, so they are dimensionless and usually between 0 and 1. If [[x_free]] is set, it rescales the total energy and thus mass and width, since these are defined with respect to the total energy. <>= subroutine map_breit_wigner (r, factor, p, m, w, x_free) real(default), intent(out) :: r real(default), intent(out) :: factor real(default), intent(in) :: p real(default), intent(in) :: m real(default), intent(in) :: w real(default), intent(in), optional :: x_free real(default) :: m2, mw, a1, a2, a3, z, tmp m2 = m ** 2 mw = m * w if (present (x_free)) then m2 = m2 / x_free mw = mw / x_free end if a1 = atan (- m2 / mw) a2 = atan ((1 - m2) / mw) a3 = (a2 - a1) * mw z = (1-p) * a1 + p * a2 if (-pi/2 < z .and. z < pi/2) then tmp = tan (z) r = max (m2 + mw * tmp, 0._default) factor = a3 * (1 + tmp ** 2) else r = 0 factor = 0 end if end subroutine map_breit_wigner subroutine map_breit_wigner_inverse (r, factor, p, m, w, x_free) real(default), intent(in) :: r real(default), intent(out) :: factor real(default), intent(out) :: p real(default), intent(in) :: m real(default), intent(in) :: w real(default) :: m2, mw, a1, a2, a3, tmp real(default), intent(in), optional :: x_free m2 = m ** 2 mw = m * w if (present (x_free)) then m2 = m2 / x_free mw = mw / x_free end if a1 = atan (- m2 / mw) a2 = atan ((1 - m2) / mw) a3 = (a2 - a1) * mw tmp = (r - m2) / mw p = (atan (tmp) - a1) / (a2 - a1) factor = a3 * (1 + tmp ** 2) end subroutine map_breit_wigner_inverse @ %def map_breit_wigner @ %def map_breit_wigner_inverse @ \subsubsection{Mapping with endpoint enhancement} This is a mapping which is close to the unit mapping, except that at the endpoint(s), the output values are exponentially enhanced. \begin{equation} y = \tanh (a \tan (\frac{\pi}{2}x)) \end{equation} We have two variants: one covers endpoints at $0$ and $1$ symmetrically, while the other one (which essentially maps one-half of the range), covers only the endpoint at $1$. <>= subroutine map_endpoint_1 (x3, factor, x1, a) real(default), intent(out) :: x3, factor real(default), intent(in) :: x1 real(default), intent(in) :: a real(default) :: x2 if (abs (x1) < 1) then x2 = tan (x1 * pi / 2) x3 = tanh (a * x2) factor = a * pi/2 * (1 + x2 ** 2) * (1 - x3 ** 2) else x3 = x1 factor = 0 end if end subroutine map_endpoint_1 subroutine map_endpoint_inverse_1 (x3, factor, x1, a) real(default), intent(in) :: x3 real(default), intent(out) :: x1, factor real(default), intent(in) :: a real(default) :: x2 if (abs (x3) < 1) then x2 = atanh (x3) / a x1 = 2 / pi * atan (x2) factor = a * pi/2 * (1 + x2 ** 2) * (1 - x3 ** 2) else x1 = x3 factor = 0 end if end subroutine map_endpoint_inverse_1 subroutine map_endpoint_01 (x4, factor, x0, a) real(default), intent(out) :: x4, factor real(default), intent(in) :: x0 real(default), intent(in) :: a real(default) :: x1, x3 x1 = 2 * x0 - 1 call map_endpoint_1 (x3, factor, x1, a) x4 = (x3 + 1) / 2 end subroutine map_endpoint_01 subroutine map_endpoint_inverse_01 (x4, factor, x0, a) real(default), intent(in) :: x4 real(default), intent(out) :: x0, factor real(default), intent(in) :: a real(default) :: x1, x3 x3 = 2 * x4 - 1 call map_endpoint_inverse_1 (x3, factor, x1, a) x0 = (x1 + 1) / 2 end subroutine map_endpoint_inverse_01 @ %def map_endpoint_1 @ %def map_endpoint_inverse_1 @ %def map_endpoint_01 @ %def map_endpoint_inverse_01 @ \subsubsection{Mapping with endpoint enhancement (ISR)} This is another endpoint mapping. It is designed to flatten the ISR singularity which is of power type at $x=1$, i.e., if \begin{equation} \sigma = \int_0^1 dx\,f(x)\,G(x) = \int_0^1 dx\,\epsilon(1-x)^{-1+\epsilon} G(x), \end{equation} we replace this by \begin{equation} r = x^\epsilon \quad\Longrightarrow\quad \sigma = \int_0^1 dr\,G(1- (1-r)^{1/\epsilon}). \end{equation} We expect that $\epsilon$ is small. The actual mapping is $r\to x$ (so $x$ emerges closer to $1$). The Jacobian that we return is thus $1/f(x)$. We compute the mapping in terms of $\bar x\equiv 1 - x$, so we can achieve the required precision. Because some compilers show quite wild numeric fluctuations, we internally convert numeric types to explicit [[double]] precision. <>= public :: map_power_1 public :: map_power_inverse_1 <>= module subroutine map_power_1 (xb, factor, rb, eps) real(default), intent(out) :: xb, factor real(default), intent(in) :: rb real(default), intent(in) :: eps end subroutine map_power_1 module subroutine map_power_inverse_1 (xb, factor, rb, eps) real(default), intent(in) :: xb real(default), intent(out) :: rb, factor real(default), intent(in) :: eps end subroutine map_power_inverse_1 <>= module subroutine map_power_1 (xb, factor, rb, eps) real(default), intent(out) :: xb, factor real(default), intent(in) :: rb real(double) :: rb_db, factor_db, eps_db, xb_db real(default), intent(in) :: eps rb_db = real (rb, kind=double) eps_db = real (eps, kind=double) xb_db = rb_db ** (1 / eps_db) if (rb_db > 0) then factor_db = xb_db / rb_db / eps_db factor = real (factor_db, kind=default) else factor = 0 end if xb = real (xb_db, kind=default) end subroutine map_power_1 module subroutine map_power_inverse_1 (xb, factor, rb, eps) real(default), intent(in) :: xb real(default), intent(out) :: rb, factor real(double) :: xb_db, factor_db, eps_db, rb_db real(default), intent(in) :: eps xb_db = real (xb, kind=double) eps_db = real (eps, kind=double) rb_db = xb_db ** eps_db if (xb_db > 0) then factor_db = xb_db / rb_db / eps_db factor = real (factor_db, kind=default) else factor = 0 end if rb = real (rb_db, kind=default) end subroutine map_power_inverse_1 @ %def map_power_1 @ %def map_power_inverse_1 @ Here we apply a power mapping to both endpoints. We divide the interval in two equal halves and apply the power mapping for the nearest endpoint, either $0$ or $1$. <>= subroutine map_power_01 (y, yb, factor, r, eps) real(default), intent(out) :: y, yb, factor real(default), intent(in) :: r real(default), intent(in) :: eps real(default) :: u, ub, zp, zm u = 2 * r - 1 if (u > 0) then ub = 2 * (1 - r) call map_power_1 (zm, factor, ub, eps) zp = 2 - zm else if (u < 0) then ub = 2 * r call map_power_1 (zp, factor, ub, eps) zm = 2 - zp else factor = 1 / eps zp = 1 zm = 1 end if y = zp / 2 yb = zm / 2 end subroutine map_power_01 subroutine map_power_inverse_01 (y, yb, factor, r, eps) real(default), intent(in) :: y, yb real(default), intent(out) :: r, factor real(default), intent(in) :: eps real(default) :: ub, zp, zm zp = 2 * y zm = 2 * yb if (zm < zp) then call map_power_inverse_1 (zm, factor, ub, eps) r = 1 - ub / 2 else if (zp < zm) then call map_power_inverse_1 (zp, factor, ub, eps) r = ub / 2 else factor = 1 / eps ub = 1 r = ub / 2 end if end subroutine map_power_inverse_01 @ %def map_power_01 @ %def map_power_inverse_01 @ \subsubsection{Structure-function channels} A structure-function chain parameterization (channel) may contain a mapping that applies to multiple structure functions. This is described by an extension of the [[sf_mapping_t]] type. In addition, it may contain mappings that apply to (other) individual structure functions. The details of these mappings are implementation-specific. The [[sf_channel_t]] type combines this information. It contains an array of map codes, one for each structure-function entry. The code values are: \begin{description} \item[none] MC input parameters $r$ directly become energy fractions $x$ \item[single] default mapping for a single structure-function entry \item[multi/s] map $r\to x$ such that one MC input parameter is $\hat s/s$ \item[multi/resonance] as before, adapted to s-channel resonance \item[multi/on-shell] as before, adapted to an on-shell particle in the s channel \item[multi/endpoint] like multi/s, but enhance the region near $r_i=1$ \item[multi/endpoint/res] endpoint mapping with resonance \item[multi/endpoint/os] endpoint mapping for on-shell \item[multi/power/os] like multi/endpoint, regulating a power singularity \end{description} <>= integer, parameter :: SFMAP_NONE = 0 integer, parameter :: SFMAP_SINGLE = 1 integer, parameter :: SFMAP_MULTI_S = 2 integer, parameter :: SFMAP_MULTI_RES = 3 integer, parameter :: SFMAP_MULTI_ONS = 4 integer, parameter :: SFMAP_MULTI_EP = 5 integer, parameter :: SFMAP_MULTI_EPR = 6 integer, parameter :: SFMAP_MULTI_EPO = 7 integer, parameter :: SFMAP_MULTI_IP = 8 integer, parameter :: SFMAP_MULTI_IPR = 9 integer, parameter :: SFMAP_MULTI_IPO = 10 integer, parameter :: SFMAP_MULTI_EI = 11 integer, parameter :: SFMAP_MULTI_SRS = 13 integer, parameter :: SFMAP_MULTI_SON = 14 @ %def SFMAP_NONE SFMAP_SINGLE @ %def SFMAP_MULTI_S SFMAP_MULTI_RES SFMAP_MULTI_ONS @ %def SFMAP_MULTI_EP SFMAP_MULTI_EPR SFMAP_MULTI_EPO @ %def SFMAP_MULTI_IP SFMAP_MULTI_IPR SFMAP_MULTI_IPO @ %def SFMAP_MULTI_EI @ %def SFMAP_MULTI_SRS SFMAP_MULTI_SON @ Then, it contains an allocatable entry for the multi mapping. This entry holds the MC-parameter indices on which the mapping applies (there may be more than one MC parameter per structure-function entry) and any parameters associated with the mapping. There can be only one multi-mapping per channel. <>= public :: sf_channel_t <>= type :: sf_channel_t integer, dimension(:), allocatable :: map_code class(sf_mapping_t), allocatable :: multi_mapping contains <> end type sf_channel_t @ %def sf_channel_t @ The output format prints a single character for each structure-function entry and, if applicable, an account of the mapping parameters. <>= procedure :: write => sf_channel_write <>= module subroutine sf_channel_write (object, unit) class(sf_channel_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine sf_channel_write <>= module subroutine sf_channel_write (object, unit) class(sf_channel_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) if (allocated (object%map_code)) then do i = 1, size (object%map_code) select case (object%map_code (i)) case (SFMAP_NONE) write (u, "(1x,A)", advance="no") "-" case (SFMAP_SINGLE) write (u, "(1x,A)", advance="no") "+" case (SFMAP_MULTI_S) write (u, "(1x,A)", advance="no") "s" case (SFMAP_MULTI_RES, SFMAP_MULTI_SRS) write (u, "(1x,A)", advance="no") "r" case (SFMAP_MULTI_ONS, SFMAP_MULTI_SON) write (u, "(1x,A)", advance="no") "o" case (SFMAP_MULTI_EP) write (u, "(1x,A)", advance="no") "e" case (SFMAP_MULTI_EPR) write (u, "(1x,A)", advance="no") "p" case (SFMAP_MULTI_EPO) write (u, "(1x,A)", advance="no") "q" case (SFMAP_MULTI_IP) write (u, "(1x,A)", advance="no") "i" case (SFMAP_MULTI_IPR) write (u, "(1x,A)", advance="no") "i" case (SFMAP_MULTI_IPO) write (u, "(1x,A)", advance="no") "i" case (SFMAP_MULTI_EI) write (u, "(1x,A)", advance="no") "i" case default write (u, "(1x,A)", advance="no") "?" end select end do else write (u, "(1x,A)", advance="no") "-" end if if (allocated (object%multi_mapping)) then write (u, "(1x,'/')", advance="no") call object%multi_mapping%write (u) else write (u, *) end if end subroutine sf_channel_write @ %def sf_channel_write @ Initializer for a single [[sf_channel]] object. <>= procedure :: init => sf_channel_init <>= module subroutine sf_channel_init (channel, n_strfun) class(sf_channel_t), intent(out) :: channel integer, intent(in) :: n_strfun end subroutine sf_channel_init <>= module subroutine sf_channel_init (channel, n_strfun) class(sf_channel_t), intent(out) :: channel integer, intent(in) :: n_strfun allocate (channel%map_code (n_strfun)) channel%map_code = SFMAP_NONE end subroutine sf_channel_init @ %def sf_channel_init @ Assignment. This merely copies intrinsic assignment. <>= generic :: assignment (=) => sf_channel_assign procedure :: sf_channel_assign <>= module subroutine sf_channel_assign (copy, original) class(sf_channel_t), intent(out) :: copy type(sf_channel_t), intent(in) :: original end subroutine sf_channel_assign <>= module subroutine sf_channel_assign (copy, original) class(sf_channel_t), intent(out) :: copy type(sf_channel_t), intent(in) :: original allocate (copy%map_code (size (original%map_code))) copy%map_code = original%map_code if (allocated (original%multi_mapping)) then allocate (copy%multi_mapping, source = original%multi_mapping) end if end subroutine sf_channel_assign @ %def sf_channel_assign @ This initializer allocates an array of channels with common number of structure-function entries, therefore it is not a type-bound procedure. <>= public :: allocate_sf_channels <>= module subroutine allocate_sf_channels (channel, n_channel, n_strfun) type(sf_channel_t), dimension(:), intent(out), allocatable :: channel integer, intent(in) :: n_channel integer, intent(in) :: n_strfun end subroutine allocate_sf_channels <>= module subroutine allocate_sf_channels (channel, n_channel, n_strfun) type(sf_channel_t), dimension(:), intent(out), allocatable :: channel integer, intent(in) :: n_channel integer, intent(in) :: n_strfun integer :: c allocate (channel (n_channel)) do c = 1, n_channel call channel(c)%init (n_strfun) end do end subroutine allocate_sf_channels @ %def allocate_sf_channels @ This marks a given subset of indices as single-mapping. <>= procedure :: activate_mapping => sf_channel_activate_mapping <>= module subroutine sf_channel_activate_mapping (channel, i_sf) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf end subroutine sf_channel_activate_mapping <>= module subroutine sf_channel_activate_mapping (channel, i_sf) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf channel%map_code(i_sf) = SFMAP_SINGLE end subroutine sf_channel_activate_mapping @ %def sf_channel_activate_mapping @ This sets an s-channel multichannel mapping. The parameter indices are not yet set. Gfortran 7/8/9 bug, has to remain in module. <>= procedure :: set_s_mapping => sf_channel_set_s_mapping <>= subroutine sf_channel_set_s_mapping (channel, i_sf, power) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: power channel%map_code(i_sf) = SFMAP_MULTI_S allocate (sf_s_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_s_mapping_t) call mapping%init (power) end select end subroutine sf_channel_set_s_mapping @ %def sf_channel_set_s_mapping @ This sets an s-channel resonance multichannel mapping. Gfortran 7/8/9 bug, has to remain in module. <>= procedure :: set_res_mapping => sf_channel_set_res_mapping <>= subroutine sf_channel_set_res_mapping (channel, i_sf, m, w, single) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in) :: m, w logical, intent(in) :: single if (single) then channel%map_code(i_sf) = SFMAP_MULTI_SRS allocate (sf_res_mapping_single_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_res_mapping_single_t) call mapping%init (m, w) end select else channel%map_code(i_sf) = SFMAP_MULTI_RES allocate (sf_res_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_res_mapping_t) call mapping%init (m, w) end select end if end subroutine sf_channel_set_res_mapping @ %def sf_channel_set_res_mapping @ This sets an s-channel on-shell multichannel mapping. The length of the [[i_sf]] array must be 2. (The first parameter actually becomes an irrelevant dummy.) Gfortran 7/8/9 bug, has to remain in module. <>= procedure :: set_os_mapping => sf_channel_set_os_mapping <>= subroutine sf_channel_set_os_mapping (channel, i_sf, m, single) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in) :: m logical, intent(in) :: single if (single) then channel%map_code(i_sf) = SFMAP_MULTI_SON allocate (sf_os_mapping_single_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_os_mapping_single_t) call mapping%init (m) end select else channel%map_code(i_sf) = SFMAP_MULTI_ONS allocate (sf_os_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_os_mapping_t) call mapping%init (m) end select end if end subroutine sf_channel_set_os_mapping @ %def sf_channel_set_os_mapping @ This sets an s-channel endpoint mapping. The parameter $a$ is the slope parameter (default 1); increasing it moves the endpoint region (at $x=1$ to lower values in the input parameter) even more. Gfortran 7/8/9 bug, has to remain in the module. <>= procedure :: set_ep_mapping => sf_channel_set_ep_mapping <>= subroutine sf_channel_set_ep_mapping (channel, i_sf, a) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: a channel%map_code(i_sf) = SFMAP_MULTI_EP allocate (sf_ep_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ep_mapping_t) call mapping%init (a = a) end select end subroutine sf_channel_set_ep_mapping @ %def sf_channel_set_ep_mapping @ This sets a resonant endpoint mapping. Gfortran 7/8/9 bug, has to remain in the module. <>= procedure :: set_epr_mapping => sf_channel_set_epr_mapping <>= subroutine sf_channel_set_epr_mapping (channel, i_sf, a, m, w) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in) :: a, m, w channel%map_code(i_sf) = SFMAP_MULTI_EPR allocate (sf_epr_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_epr_mapping_t) call mapping%init (a, m, w) end select end subroutine sf_channel_set_epr_mapping @ %def sf_channel_set_epr_mapping @ This sets an on-shell endpoint mapping. Gfortran 7/8/9 bug, has to remain in the module. <>= procedure :: set_epo_mapping => sf_channel_set_epo_mapping <>= subroutine sf_channel_set_epo_mapping (channel, i_sf, a, m) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in) :: a, m channel%map_code(i_sf) = SFMAP_MULTI_EPO allocate (sf_epo_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_epo_mapping_t) call mapping%init (a, m) end select end subroutine sf_channel_set_epo_mapping @ %def sf_channel_set_epo_mapping @ This sets an s-channel power mapping, regulating a singularity of type $(1-x)^{-1+\epsilon}$. The parameter $\epsilon$ depends on the structure function. Gfortran 7/8/9 bug, has to remain in the module. <>= procedure :: set_ip_mapping => sf_channel_set_ip_mapping <>= subroutine sf_channel_set_ip_mapping (channel, i_sf, eps) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: eps channel%map_code(i_sf) = SFMAP_MULTI_IP allocate (sf_ip_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ip_mapping_t) call mapping%init (eps) end select end subroutine sf_channel_set_ip_mapping @ %def sf_channel_set_ip_mapping @ This sets an s-channel resonant power mapping, regulating a singularity of type $(1-x)^{-1+\epsilon}$ in the presence of an s-channel resonance. The parameter $\epsilon$ depends on the structure function. Gfortran 7/8/9 bug, has to remain in the module. <>= procedure :: set_ipr_mapping => sf_channel_set_ipr_mapping <>= subroutine sf_channel_set_ipr_mapping (channel, i_sf, eps, m, w) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: eps, m, w channel%map_code(i_sf) = SFMAP_MULTI_IPR allocate (sf_ipr_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ipr_mapping_t) call mapping%init (eps, m, w) end select end subroutine sf_channel_set_ipr_mapping @ %def sf_channel_set_ipr_mapping @ This sets an on-shell power mapping, regulating a singularity of type $(1-x)^{-1+\epsilon}$ for the production of a single on-shell particle.. The parameter $\epsilon$ depends on the structure function. Gfortran 7/8/9 bug: has to remain in module. <>= procedure :: set_ipo_mapping => sf_channel_set_ipo_mapping <>= subroutine sf_channel_set_ipo_mapping (channel, i_sf, eps, m) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: eps, m channel%map_code(i_sf) = SFMAP_MULTI_IPO allocate (sf_ipo_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ipo_mapping_t) call mapping%init (eps, m) end select end subroutine sf_channel_set_ipo_mapping @ %def sf_channel_set_ipo_mapping @ This sets a combined endpoint/ISR mapping. Gfortran 7/8/9 bug, remains in module. <>= procedure :: set_ei_mapping => sf_channel_set_ei_mapping <>= subroutine sf_channel_set_ei_mapping (channel, i_sf, a, eps) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: a, eps channel%map_code(i_sf) = SFMAP_MULTI_EI allocate (sf_ei_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ei_mapping_t) call mapping%init (a, eps) end select end subroutine sf_channel_set_ei_mapping @ %def sf_channel_set_ei_mapping @ This sets a combined endpoint/ISR mapping with resonance. Gfortran 7/8/9 bug, remains in module. <>= procedure :: set_eir_mapping => sf_channel_set_eir_mapping <>= subroutine sf_channel_set_eir_mapping (channel, i_sf, a, eps, m, w) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: a, eps, m, w channel%map_code(i_sf) = SFMAP_MULTI_EI allocate (sf_eir_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_eir_mapping_t) call mapping%init (a, eps, m, w) end select end subroutine sf_channel_set_eir_mapping @ %def sf_channel_set_eir_mapping @ This sets a combined endpoint/ISR mapping, on-shell. Gfortran 7/8/9 bug, remains in module. <>= procedure :: set_eio_mapping => sf_channel_set_eio_mapping <>= subroutine sf_channel_set_eio_mapping (channel, i_sf, a, eps, m) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: a, eps, m channel%map_code(i_sf) = SFMAP_MULTI_EI allocate (sf_eio_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_eio_mapping_t) call mapping%init (a, eps, m) end select end subroutine sf_channel_set_eio_mapping @ %def sf_channel_set_eio_mapping @ Return true if the mapping code at position [[i_sf]] is [[SFMAP_SINGLE]]. <>= procedure :: is_single_mapping => sf_channel_is_single_mapping <>= module function sf_channel_is_single_mapping (channel, i_sf) result (flag) class(sf_channel_t), intent(in) :: channel integer, intent(in) :: i_sf logical :: flag end function sf_channel_is_single_mapping <>= module function sf_channel_is_single_mapping (channel, i_sf) result (flag) class(sf_channel_t), intent(in) :: channel integer, intent(in) :: i_sf logical :: flag flag = channel%map_code(i_sf) == SFMAP_SINGLE end function sf_channel_is_single_mapping @ %def sf_channel_is_single_mapping @ Return true if the mapping code at position [[i_sf]] is any of the [[SFMAP_MULTI]] mappings. <>= procedure :: is_multi_mapping => sf_channel_is_multi_mapping <>= module function sf_channel_is_multi_mapping (channel, i_sf) result (flag) class(sf_channel_t), intent(in) :: channel integer, intent(in) :: i_sf logical :: flag end function sf_channel_is_multi_mapping <>= module function sf_channel_is_multi_mapping (channel, i_sf) result (flag) class(sf_channel_t), intent(in) :: channel integer, intent(in) :: i_sf logical :: flag select case (channel%map_code(i_sf)) case (SFMAP_NONE, SFMAP_SINGLE) flag = .false. case default flag = .true. end select end function sf_channel_is_multi_mapping @ %def sf_channel_is_multi_mapping @ Return the number of parameters that the multi-mapping requires. The mapping object must be allocated. <>= procedure :: get_multi_mapping_n_par => sf_channel_get_multi_mapping_n_par <>= module function sf_channel_get_multi_mapping_n_par (channel) result (n_par) class(sf_channel_t), intent(in) :: channel integer :: n_par end function sf_channel_get_multi_mapping_n_par <>= module function sf_channel_get_multi_mapping_n_par (channel) result (n_par) class(sf_channel_t), intent(in) :: channel integer :: n_par if (allocated (channel%multi_mapping)) then n_par = channel%multi_mapping%get_n_dim () else n_par = 0 end if end function sf_channel_get_multi_mapping_n_par @ %def sf_channel_get_multi_mapping_n_par @ Return true if there is any nontrivial mapping in any of the channels. <>= public :: any_sf_channel_has_mapping <>= module function any_sf_channel_has_mapping (channel) result (flag) type(sf_channel_t), dimension(:), intent(in) :: channel logical :: flag end function any_sf_channel_has_mapping <>= module function any_sf_channel_has_mapping (channel) result (flag) type(sf_channel_t), dimension(:), intent(in) :: channel logical :: flag integer :: c flag = .false. do c = 1, size (channel) flag = flag .or. any (channel(c)%map_code /= SFMAP_NONE) end do end function any_sf_channel_has_mapping @ %def any_sf_channel_has_mapping @ Set a parameter index for an active multi mapping. We assume that the index array is allocated properly. <>= procedure :: set_par_index => sf_channel_set_par_index <>= module subroutine sf_channel_set_par_index (channel, j, i_par) class(sf_channel_t), intent(inout) :: channel integer, intent(in) :: j integer, intent(in) :: i_par end subroutine sf_channel_set_par_index <>= module subroutine sf_channel_set_par_index (channel, j, i_par) class(sf_channel_t), intent(inout) :: channel integer, intent(in) :: j integer, intent(in) :: i_par associate (mapping => channel%multi_mapping) if (j >= 1 .and. j <= mapping%get_n_dim ()) then if (mapping%get_index (j) == 0) then call channel%multi_mapping%set_index (j, i_par) else call msg_bug ("Structure-function setup: mapping index set twice") end if else call msg_bug ("Structure-function setup: mapping index out of range") end if end associate end subroutine sf_channel_set_par_index @ %def sf_channel_set_par_index @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_mappings_ut.f90]]>>= <> module sf_mappings_ut use unit_tests use sf_mappings_uti <> <> contains <> end module sf_mappings_ut @ %def sf_mappings_ut @ <<[[sf_mappings_uti.f90]]>>= <> module sf_mappings_uti <> use format_defs, only: FMT_11, FMT_12, FMT_13, FMT_14, FMT_15, FMT_16 use sf_mappings <> <> contains <> end module sf_mappings_uti @ %def sf_mappings_ut @ API: driver for the unit tests below. <>= public :: sf_mappings_test <>= subroutine sf_mappings_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_mappings_test @ %def sf_mappings_test @ \subsubsection{Check standard mapping} Probe the standard mapping of the unit square for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_1, "sf_mappings_1", & "standard pair mapping", & u, results) <>= public :: sf_mappings_1 <>= subroutine sf_mappings_1 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_1" write (u, "(A)") "* Purpose: probe standard mapping" write (u, "(A)") allocate (sf_s_mapping_t :: mapping) select type (mapping) type is (sf_s_mapping_t) call mapping%init () call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.1):" p = [0.1_default, 0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) allocate (sf_s_mapping_t :: mapping) select type (mapping) type is (sf_s_mapping_t) call mapping%init (power=2._default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select write (u, *) call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.1):" p = [0.1_default, 0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_1" end subroutine sf_mappings_1 @ %def sf_mappings_1 @ \subsubsection{Channel entries} Construct channel entries and print them. <>= call test (sf_mappings_2, "sf_mappings_2", & "structure-function mapping channels", & u, results) <>= public :: sf_mappings_2 <>= subroutine sf_mappings_2 (u) integer, intent(in) :: u type(sf_channel_t), dimension(:), allocatable :: channel integer :: c write (u, "(A)") "* Test output: sf_mappings_2" write (u, "(A)") "* Purpose: construct and display & &mapping-channel objects" write (u, "(A)") call allocate_sf_channels (channel, n_channel = 8, n_strfun = 2) call channel(2)%activate_mapping ([1]) call channel(3)%set_s_mapping ([1,2]) call channel(4)%set_s_mapping ([1,2], power=2._default) call channel(5)%set_res_mapping ([1,2], m = 0.5_default, w = 0.1_default, single = .false.) call channel(6)%set_os_mapping ([1,2], m = 0.5_default, single = .false.) call channel(7)%set_res_mapping ([1], m = 0.5_default, w = 0.1_default, single = .true.) call channel(8)%set_os_mapping ([1], m = 0.5_default, single = .true.) call channel(3)%set_par_index (1, 1) call channel(3)%set_par_index (2, 4) call channel(4)%set_par_index (1, 1) call channel(4)%set_par_index (2, 4) call channel(5)%set_par_index (1, 1) call channel(5)%set_par_index (2, 3) call channel(6)%set_par_index (1, 1) call channel(6)%set_par_index (2, 2) call channel(7)%set_par_index (1, 1) call channel(8)%set_par_index (1, 1) do c = 1, size (channel) write (u, "(I0,':')", advance="no") c call channel(c)%write (u) end do write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_2" end subroutine sf_mappings_2 @ %def sf_mappings_2 @ \subsubsection{Check resonance mapping} Probe the resonance mapping of the unit square for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. The resonance mass is at $1/2$ the energy, the width is $1/10$. <>= call test (sf_mappings_3, "sf_mappings_3", & "resonant pair mapping", & u, results) <>= public :: sf_mappings_3 <>= subroutine sf_mappings_3 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_3" write (u, "(A)") "* Purpose: probe resonance pair mapping" write (u, "(A)") allocate (sf_res_mapping_t :: mapping) select type (mapping) type is (sf_res_mapping_t) call mapping%init (0.5_default, 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.1):" p = [0.1_default, 0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_3" end subroutine sf_mappings_3 @ %def sf_mappings_3 @ \subsubsection{Check on-shell mapping} Probe the on-shell mapping of the unit square for different parameter values. Also calculates integrals. In this case, the Jacobian is constant and given by $|\log m^2|$, so this is also the value of the integral. The factor results from the variable change in the $\delta$ function $\delta (m^2 - x_1x_2)$ which multiplies the cross section for the case at hand. For the test, the (rescaled) resonance mass is set at $1/2$ the energy. <>= call test (sf_mappings_4, "sf_mappings_4", & "on-shell pair mapping", & u, results) <>= public :: sf_mappings_4 <>= subroutine sf_mappings_4 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_4" write (u, "(A)") "* Purpose: probe on-shell pair mapping" write (u, "(A)") allocate (sf_os_mapping_t :: mapping) select type (mapping) type is (sf_os_mapping_t) call mapping%init (0.5_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0,0.1):" p = [0._default, 0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0,1.0):" p = [0._default, 1.0_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_4" end subroutine sf_mappings_4 @ %def sf_mappings_4 @ \subsubsection{Check endpoint mapping} Probe the endpoint mapping of the unit square for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_5, "sf_mappings_5", & "endpoint pair mapping", & u, results) <>= public :: sf_mappings_5 <>= subroutine sf_mappings_5 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_5" write (u, "(A)") "* Purpose: probe endpoint pair mapping" write (u, "(A)") allocate (sf_ep_mapping_t :: mapping) select type (mapping) type is (sf_ep_mapping_t) call mapping%init () call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_5" end subroutine sf_mappings_5 @ %def sf_mappings_5 @ \subsubsection{Check endpoint resonant mapping} Probe the endpoint mapping with resonance. Also calculates integrals. <>= call test (sf_mappings_6, "sf_mappings_6", & "endpoint resonant mapping", & u, results) <>= public :: sf_mappings_6 <>= subroutine sf_mappings_6 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_6" write (u, "(A)") "* Purpose: probe endpoint resonant mapping" write (u, "(A)") allocate (sf_epr_mapping_t :: mapping) select type (mapping) type is (sf_epr_mapping_t) call mapping%init (a = 1._default, m = 0.5_default, w = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Same mapping without resonance:" write (u, "(A)") allocate (sf_epr_mapping_t :: mapping) select type (mapping) type is (sf_epr_mapping_t) call mapping%init (a = 1._default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_6" end subroutine sf_mappings_6 @ %def sf_mappings_6 @ \subsubsection{Check endpoint on-shell mapping} Probe the endpoint mapping with an on-shell particle. Also calculates integrals. <>= call test (sf_mappings_7, "sf_mappings_7", & "endpoint on-shell mapping", & u, results) <>= public :: sf_mappings_7 <>= subroutine sf_mappings_7 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_7" write (u, "(A)") "* Purpose: probe endpoint on-shell mapping" write (u, "(A)") allocate (sf_epo_mapping_t :: mapping) select type (mapping) type is (sf_epo_mapping_t) call mapping%init (a = 1._default, m = 0.5_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_7" end subroutine sf_mappings_7 @ %def sf_mappings_7 @ \subsubsection{Check power mapping} Probe the power mapping of the unit square for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_8, "sf_mappings_8", & "power pair mapping", & u, results) <>= public :: sf_mappings_8 <>= subroutine sf_mappings_8 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p, pb write (u, "(A)") "* Test output: sf_mappings_8" write (u, "(A)") "* Purpose: probe power pair mapping" write (u, "(A)") allocate (sf_ip_mapping_t :: mapping) select type (mapping) type is (sf_ip_mapping_t) call mapping%init (eps = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0.5):" p = [0._default, 0.5_default] pb= [1._default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] pb= [0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9,0.5):" p = [0.9_default, 0.5_default] pb= [0.1_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] pb= [0.3_default, 0.8_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.8):" p = [0.7_default, 0.8_default] pb= [0.3_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.99,0.02):" p = [0.99_default, 0.02_default] pb= [0.01_default, 0.98_default] call mapping%check (u, p, pb, FMT_14, FMT_12) write (u, *) write (u, "(A)") "Probe at (0.99,0.98):" p = [0.99_default, 0.98_default] pb= [0.01_default, 0.02_default] call mapping%check (u, p, pb, FMT_14, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_8" end subroutine sf_mappings_8 @ %def sf_mappings_8 @ \subsubsection{Check resonant power mapping} Probe the power mapping of the unit square, adapted for an s-channel resonance, for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_9, "sf_mappings_9", & "power resonance mapping", & u, results) <>= public :: sf_mappings_9 <>= subroutine sf_mappings_9 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p, pb write (u, "(A)") "* Test output: sf_mappings_9" write (u, "(A)") "* Purpose: probe power resonant pair mapping" write (u, "(A)") allocate (sf_ipr_mapping_t :: mapping) select type (mapping) type is (sf_ipr_mapping_t) call mapping%init (eps = 0.1_default, m = 0.5_default, w = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0.5):" p = [0._default, 0.5_default] pb= [1._default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] pb= [0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9,0.5):" p = [0.9_default, 0.5_default] pb= [0.1_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] pb= [0.3_default, 0.8_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.8):" p = [0.7_default, 0.8_default] pb= [0.3_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9999,0.02):" p = [0.9999_default, 0.02_default] pb= [0.0001_default, 0.98_default] call mapping%check (u, p, pb, FMT_11, FMT_12) write (u, *) write (u, "(A)") "Probe at (0.9999,0.98):" p = [0.9999_default, 0.98_default] pb= [0.0001_default, 0.02_default] call mapping%check (u, p, pb, FMT_11, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Same mapping without resonance:" write (u, "(A)") allocate (sf_ipr_mapping_t :: mapping) select type (mapping) type is (sf_ipr_mapping_t) call mapping%init (eps = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0.5):" p = [0._default, 0.5_default] pb= [1._default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] pb= [0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9,0.5):" p = [0.9_default, 0.5_default] pb= [0.1_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] pb= [0.3_default, 0.8_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.8):" p = [0.7_default, 0.8_default] pb= [0.3_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_9" end subroutine sf_mappings_9 @ %def sf_mappings_9 @ \subsubsection{Check on-shell power mapping} Probe the power mapping of the unit square, adapted for single-particle production, for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_10, "sf_mappings_10", & "power on-shell mapping", & u, results) <>= public :: sf_mappings_10 <>= subroutine sf_mappings_10 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p, pb write (u, "(A)") "* Test output: sf_mappings_10" write (u, "(A)") "* Purpose: probe power on-shell mapping" write (u, "(A)") allocate (sf_ipo_mapping_t :: mapping) select type (mapping) type is (sf_ipo_mapping_t) call mapping%init (eps = 0.1_default, m = 0.5_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0.5):" p = [0._default, 0.5_default] pb= [1._default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0,0.02):" p = [0._default, 0.02_default] pb= [1._default, 0.98_default] call mapping%check (u, p, pb, FMT_15, FMT_12) write (u, *) write (u, "(A)") "Probe at (0,0.98):" p = [0._default, 0.98_default] pb= [1._default, 0.02_default] call mapping%check (u, p, pb, FMT_15, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_10" end subroutine sf_mappings_10 @ %def sf_mappings_10 @ \subsubsection{Check combined endpoint-power mapping} Probe the mapping for the beamstrahlung/ISR combination. <>= call test (sf_mappings_11, "sf_mappings_11", & "endpoint/power combined mapping", & u, results) <>= public :: sf_mappings_11 <>= subroutine sf_mappings_11 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(4) :: p, pb write (u, "(A)") "* Test output: sf_mappings_11" write (u, "(A)") "* Purpose: probe power pair mapping" write (u, "(A)") allocate (sf_ei_mapping_t :: mapping) select type (mapping) type is (sf_ei_mapping_t) call mapping%init (eps = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) call mapping%set_index (3, 3) call mapping%set_index (4, 4) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0.5, 0.5, 0.5, 0.5):" p = [0.5_default, 0.5_default, 0.5_default, 0.5_default] pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7, 0.2, 0.4, 0.8):" p = [0.7_default, 0.2_default, 0.4_default, 0.8_default] pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9, 0.06, 0.95, 0.1):" p = [0.9_default, 0.06_default, 0.95_default, 0.1_default] pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default] call mapping%check (u, p, pb, FMT_13, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_11" end subroutine sf_mappings_11 @ %def sf_mappings_11 @ \subsubsection{Check resonant endpoint-power mapping} Probe the mapping for the beamstrahlung/ISR combination. <>= call test (sf_mappings_12, "sf_mappings_12", & "endpoint/power resonant combined mapping", & u, results) <>= public :: sf_mappings_12 <>= subroutine sf_mappings_12 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(4) :: p, pb write (u, "(A)") "* Test output: sf_mappings_12" write (u, "(A)") "* Purpose: probe resonant combined mapping" write (u, "(A)") allocate (sf_eir_mapping_t :: mapping) select type (mapping) type is (sf_eir_mapping_t) call mapping%init (a = 1._default, & eps = 0.1_default, m = 0.5_default, w = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) call mapping%set_index (3, 3) call mapping%set_index (4, 4) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0.5, 0.5, 0.5, 0.5):" p = [0.5_default, 0.5_default, 0.5_default, 0.5_default] pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7, 0.2, 0.4, 0.8):" p = [0.7_default, 0.2_default, 0.4_default, 0.8_default] pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9, 0.06, 0.95, 0.1):" p = [0.9_default, 0.06_default, 0.95_default, 0.1_default] pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default] call mapping%check (u, p, pb, FMT_15, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_12" end subroutine sf_mappings_12 @ %def sf_mappings_12 @ \subsubsection{Check on-shell endpoint-power mapping} Probe the mapping for the beamstrahlung/ISR combination. <>= call test (sf_mappings_13, "sf_mappings_13", & "endpoint/power on-shell combined mapping", & u, results) <>= public :: sf_mappings_13 <>= subroutine sf_mappings_13 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(4) :: p, pb write (u, "(A)") "* Test output: sf_mappings_13" write (u, "(A)") "* Purpose: probe on-shell combined mapping" write (u, "(A)") allocate (sf_eio_mapping_t :: mapping) select type (mapping) type is (sf_eio_mapping_t) call mapping%init (a = 1._default, eps = 0.1_default, m = 0.5_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) call mapping%set_index (3, 3) call mapping%set_index (4, 4) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0.5, 0.5, 0.5, 0.5):" p = [0.5_default, 0.5_default, 0.5_default, 0.5_default] pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7, 0.2, 0.4, 0.8):" p = [0.7_default, 0.2_default, 0.4_default, 0.8_default] pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9, 0.06, 0.95, 0.1):" p = [0.9_default, 0.06_default, 0.95_default, 0.1_default] pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default] call mapping%check (u, p, pb, FMT_14, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_13" end subroutine sf_mappings_13 @ %def sf_mappings_13 @ \subsubsection{Check rescaling} Check the rescaling factor in on-shell basic mapping. <>= call test (sf_mappings_14, "sf_mappings_14", & "rescaled on-shell mapping", & u, results) <>= public :: sf_mappings_14 <>= subroutine sf_mappings_14 (u) integer, intent(in) :: u real(default), dimension(2) :: p2, r2 real(default), dimension(1) :: p1, r1 real(default) :: f, x_free, m2 write (u, "(A)") "* Test output: sf_mappings_14" write (u, "(A)") "* Purpose: probe rescaling in os mapping" write (u, "(A)") x_free = 0.9_default m2 = 0.5_default write (u, "(A)") "* Two parameters" write (u, "(A)") p2 = [0.1_default, 0.2_default] call map_on_shell (r2, f, p2, -log (m2), x_free) write (u, "(A,9(1x," // FMT_14 // "))") "p =", p2 write (u, "(A,9(1x," // FMT_14 // "))") "r =", r2 write (u, "(A,9(1x," // FMT_14 // "))") "f =", f write (u, "(A,9(1x," // FMT_14 // "))") "*r=", x_free * product (r2) write (u, *) call map_on_shell_inverse (r2, f, p2, -log (m2), x_free) write (u, "(A,9(1x," // FMT_14 // "))") "p =", p2 write (u, "(A,9(1x," // FMT_14 // "))") "r =", r2 write (u, "(A,9(1x," // FMT_14 // "))") "f =", f write (u, "(A,9(1x," // FMT_14 // "))") "*r=", x_free * product (r2) write (u, "(A)") write (u, "(A)") "* One parameter" write (u, "(A)") p1 = [0.1_default] call map_on_shell_single (r1, f, p1, -log (m2), x_free) write (u, "(A,9(1x," // FMT_14 // "))") "p =", p1 write (u, "(A,9(1x," // FMT_14 // "))") "r =", r1 write (u, "(A,9(1x," // FMT_14 // "))") "f =", f write (u, "(A,9(1x," // FMT_14 // "))") "*r=", x_free * product (r1) write (u, *) call map_on_shell_single_inverse (r1, f, p1, -log (m2), x_free) write (u, "(A,9(1x," // FMT_14 // "))") "p =", p1 write (u, "(A,9(1x," // FMT_14 // "))") "r =", r1 write (u, "(A,9(1x," // FMT_14 // "))") "f =", f write (u, "(A,9(1x," // FMT_14 // "))") "*r=", x_free * product (r1) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_14" end subroutine sf_mappings_14 @ %def sf_mappings_14 @ \subsubsection{Check single parameter resonance mapping} Probe the resonance mapping of the unit interval for different parameter values. Also calculates integrals. The resonance mass is at $1/2$ the energy, the width is $1/10$. <>= call test (sf_mappings_15, "sf_mappings_15", & "resonant single mapping", & u, results) <>= public :: sf_mappings_15 <>= subroutine sf_mappings_15 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(1) :: p write (u, "(A)") "* Test output: sf_mappings_15" write (u, "(A)") "* Purpose: probe resonance single mapping" write (u, "(A)") allocate (sf_res_mapping_single_t :: mapping) select type (mapping) type is (sf_res_mapping_single_t) call mapping%init (0.5_default, 0.1_default) call mapping%set_index (1, 1) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0):" p = [0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5):" p = [0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1):" p = [0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_15" end subroutine sf_mappings_15 @ %def sf_mappings_15 @ \subsubsection{Check single parameter on-shell mapping} Probe the on-shell (pseudo) mapping of the unit interval for different parameter values. Also calculates integrals. The resonance mass is at $1/2$ the energy. <>= call test (sf_mappings_16, "sf_mappings_16", & "on-shell single mapping", & u, results) <>= public :: sf_mappings_16 <>= subroutine sf_mappings_16 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(1) :: p write (u, "(A)") "* Test output: sf_mappings_16" write (u, "(A)") "* Purpose: probe on-shell single mapping" write (u, "(A)") allocate (sf_os_mapping_single_t :: mapping) select type (mapping) type is (sf_os_mapping_single_t) call mapping%init (0.5_default) call mapping%set_index (1, 1) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0):" p = [0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5):" p = [0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_16" end subroutine sf_mappings_16 @ %def sf_mappings_16 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Structure function base} <<[[sf_base.f90]]>>= <> module sf_base <> <> use numeric_utils, only: pacify use lorentz use quantum_numbers use pdg_arrays use interactions use evaluators use beams use sf_aux use sf_mappings <> <> <> <> <> interface <> end interface end module sf_base @ %def sf_base @ <<[[sf_base_sub.f90]]>>= <> submodule (sf_base) sf_base_s use io_units use format_utils, only: write_separator use format_defs, only: FMT_17, FMT_19 use constants, only: one, two use diagnostics use physics_defs, only: n_beams_rescaled implicit none contains <> end submodule sf_base_s @ %def sf_base_s @ \subsection{Abstract rescale data-type} NLO calculations require the treatment of initial state parton radiation. The radiation of a parton rescales the energy fraction which enters the hard process. We allow for different rescale settings by extending the abstract. [[sf_rescale_t]] data type. <>= public :: sf_rescale_t <>= type, abstract :: sf_rescale_t integer :: i_beam = 0 contains <> end type sf_rescale_t @ %def sf_rescale_t @ <>= procedure (sf_rescale_apply), deferred :: apply <>= abstract interface subroutine sf_rescale_apply (func, x) import class(sf_rescale_t), intent(in) :: func real(default), intent(inout) :: x end subroutine sf_rescale_apply end interface @ %def rescale_apply @ <>= procedure :: set_i_beam => sf_rescale_set_i_beam <>= module subroutine sf_rescale_set_i_beam (func, i_beam) class(sf_rescale_t), intent(inout) :: func integer, intent(in) :: i_beam end subroutine sf_rescale_set_i_beam <>= module subroutine sf_rescale_set_i_beam (func, i_beam) class(sf_rescale_t), intent(inout) :: func integer, intent(in) :: i_beam func%i_beam = i_beam end subroutine sf_rescale_set_i_beam @ %def rescale_set_i_beam @ <>= public :: sf_rescale_collinear_t <>= type, extends (sf_rescale_t) :: sf_rescale_collinear_t real(default) :: xi_tilde contains <> end type sf_rescale_collinear_t @ %def sf_rescale_collinear_t @ For the subtraction terms we need to rescale the Born $x$ of both beams in the collinear limit. This leaves one beam unaffected and rescales the other according to \begin{equation} x = \frac{\overline{x}}{1-\xi} \end{equation} which is the collinear limit of [[sf_rescale_real_apply]]. <>= procedure :: apply => sf_rescale_collinear_apply <>= module subroutine sf_rescale_collinear_apply (func, x) class(sf_rescale_collinear_t), intent(in) :: func real(default), intent(inout) :: x end subroutine sf_rescale_collinear_apply <>= module subroutine sf_rescale_collinear_apply (func, x) class(sf_rescale_collinear_t), intent(in) :: func real(default), intent(inout) :: x real(default) :: xi if (debug2_active (D_BEAMS)) then print *, 'Rescaling function - Collinear: ' print *, 'Input, unscaled x: ', x print *, 'xi_tilde: ', func%xi_tilde end if xi = func%xi_tilde * (one - x) x = x / (one - xi) if (debug2_active (D_BEAMS)) print *, 'rescaled x: ', x end subroutine sf_rescale_collinear_apply @ %def sf_rescale_collinear_apply @ <>= procedure :: set => sf_rescale_collinear_set <>= module subroutine sf_rescale_collinear_set (func, xi_tilde) class(sf_rescale_collinear_t), intent(inout) :: func real(default), intent(in) :: xi_tilde end subroutine sf_rescale_collinear_set <>= module subroutine sf_rescale_collinear_set (func, xi_tilde) class(sf_rescale_collinear_t), intent(inout) :: func real(default), intent(in) :: xi_tilde func%xi_tilde = xi_tilde end subroutine sf_rescale_collinear_set @ %def sf_rescale_collinear_set @ <>= public :: sf_rescale_real_t <>= type, extends (sf_rescale_t) :: sf_rescale_real_t real(default) :: xi, y contains <> end type sf_rescale_real_t @ %def sf_rescale_real_t @ In case of IS Splittings, the beam $x$ changes from Born to real and thus needs to be rescaled according to \begin{equation} x_\oplus = \frac{\overline{x}_\oplus}{\sqrt{1-\xi}} \sqrt{\frac{2-\xi(1-y)}{2-\xi(1+y)}} , \qquad x_\ominus = \frac{\overline{x}_\ominus}{\sqrt{1-\xi}} \sqrt{\frac{2-\xi(1+y)}{2-\xi(1-y)}} \end{equation} Refs: \begin{itemize} \item[\textbullet] [0709.2092] Eq. (5.7). \item[\textbullet] [0907.4076] Eq. (2.21). \item Christian Weiss' PhD Thesis (DESY-THESIS-2017-025), Eq. (A.2.3). \end{itemize} <>= procedure :: apply => sf_rescale_real_apply <>= module subroutine sf_rescale_real_apply (func, x) class(sf_rescale_real_t), intent(in) :: func real(default), intent(inout) :: x end subroutine sf_rescale_real_apply <>= module subroutine sf_rescale_real_apply (func, x) class(sf_rescale_real_t), intent(in) :: func real(default), intent(inout) :: x real(default) :: onepy, onemy if (debug2_active (D_BEAMS)) then print *, 'Rescaling function - Real: ' print *, 'Input, unscaled: ', x print *, 'Beam index: ', func%i_beam print *, 'xi: ', func%xi, 'y: ', func%y end if x = x / sqrt (one - func%xi) onepy = one + func%y; onemy = one - func%y if (func%i_beam == 1) then x = x * sqrt ((two - func%xi * onemy) / (two - func%xi * onepy)) else if (func%i_beam == 2) then x = x * sqrt ((two - func%xi * onepy) / (two - func%xi * onemy)) else call msg_fatal ("sf_rescale_real_apply - invalid beam index") end if if (debug2_active (D_BEAMS)) print *, 'rescaled x: ', x end subroutine sf_rescale_real_apply @ %def sf_rescale_real_apply @ <>= procedure :: set => sf_rescale_real_set <>= module subroutine sf_rescale_real_set (func, xi, y) class(sf_rescale_real_t), intent(inout) :: func real(default), intent(in) :: xi, y end subroutine sf_rescale_real_set <>= module subroutine sf_rescale_real_set (func, xi, y) class(sf_rescale_real_t), intent(inout) :: func real(default), intent(in) :: xi, y func%xi = xi; func%y = y end subroutine sf_rescale_real_set @ %def sf_rescale_real_set <>= public :: sf_rescale_dglap_t <>= type, extends(sf_rescale_t) :: sf_rescale_dglap_t real(default), dimension(:), allocatable :: z contains <> end type sf_rescale_dglap_t @ %def sf_rescale_dglap_t @ <>= procedure :: apply => sf_rescale_dglap_apply <>= module subroutine sf_rescale_dglap_apply (func, x) class(sf_rescale_dglap_t), intent(in) :: func real(default), intent(inout) :: x end subroutine sf_rescale_dglap_apply <>= module subroutine sf_rescale_dglap_apply (func, x) class(sf_rescale_dglap_t), intent(in) :: func real(default), intent(inout) :: x if (debug2_active (D_BEAMS)) then print *, "Rescaling function - DGLAP:" print *, "Input: ", x print *, "Beam index: ", func%i_beam print *, "z: ", func%z end if x = x / func%z(func%i_beam) if (debug2_active (D_BEAMS)) print *, "scaled x: ", x end subroutine sf_rescale_dglap_apply @ %def sf_rescale_dglap_apply @ <>= procedure :: set => sf_rescale_dglap_set <>= module subroutine sf_rescale_dglap_set (func, z) class(sf_rescale_dglap_t), intent(inout) :: func real(default), dimension(:), intent(in) :: z end subroutine sf_rescale_dglap_set <>= module subroutine sf_rescale_dglap_set (func, z) class(sf_rescale_dglap_t), intent(inout) :: func real(default), dimension(:), intent(in) :: z func%z = z end subroutine sf_rescale_dglap_set @ %def sf_rescale_dglap_set @ \subsection{Abstract structure-function data type} This type should hold all configuration data for a specific type of structure function. The base object is empty; the implementations will fill it. <>= public :: sf_data_t <>= type, abstract :: sf_data_t contains <> end type sf_data_t @ %def sf_data_t @ Output. <>= procedure (sf_data_write), deferred :: write <>= abstract interface subroutine sf_data_write (data, unit, verbose) import class(sf_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine sf_data_write end interface @ %def sf_data_write @ Return true if this structure function is in generator mode. In that case, all parameters are free, otherwise bound. (We do not support mixed cases.) Default is: no generator. <>= procedure :: is_generator => sf_data_is_generator <>= module function sf_data_is_generator (data) result (flag) class(sf_data_t), intent(in) :: data logical :: flag end function sf_data_is_generator <>= module function sf_data_is_generator (data) result (flag) class(sf_data_t), intent(in) :: data logical :: flag flag = .false. end function sf_data_is_generator @ %def sf_data_is_generator @ Return the number of input parameters that determine the structure function. <>= procedure (sf_data_get_int), deferred :: get_n_par <>= abstract interface function sf_data_get_int (data) result (n) import class(sf_data_t), intent(in) :: data integer :: n end function sf_data_get_int end interface @ %def sf_data_get_int @ Return the outgoing particle PDG codes for the current setup. The codes can be an array of particles, for each beam. <>= procedure (sf_data_get_pdg_out), deferred :: get_pdg_out <>= abstract interface subroutine sf_data_get_pdg_out (data, pdg_out) import class(sf_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out end subroutine sf_data_get_pdg_out end interface @ %def sf_data_get_pdg_out @ Allocate a matching structure function interaction object and properly initialize it. <>= procedure (sf_data_allocate_sf_int), deferred :: allocate_sf_int <>= abstract interface subroutine sf_data_allocate_sf_int (data, sf_int) import class(sf_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int end subroutine sf_data_allocate_sf_int end interface @ %def sf_data_allocate_sf_int @ Return the PDF set index, if applicable. We implement a default method which returns zero. The PDF (builtin and LHA) implementations will override this. <>= procedure :: get_pdf_set => sf_data_get_pdf_set <>= elemental module function sf_data_get_pdf_set (data) result (pdf_set) class(sf_data_t), intent(in) :: data integer :: pdf_set end function sf_data_get_pdf_set <>= elemental module function sf_data_get_pdf_set (data) result (pdf_set) class(sf_data_t), intent(in) :: data integer :: pdf_set pdf_set = 0 end function sf_data_get_pdf_set @ %def sf_data_get_pdf_set @ Return the spectrum file, if applicable. We implement a default method which returns zero. CIRCE1, CIRCE2 and the beam spectrum will override this. <>= procedure :: get_beam_file => sf_data_get_beam_file <>= module function sf_data_get_beam_file (data) result (file) class(sf_data_t), intent(in) :: data type(string_t) :: file end function sf_data_get_beam_file <>= module function sf_data_get_beam_file (data) result (file) class(sf_data_t), intent(in) :: data type(string_t) :: file file = "" end function sf_data_get_beam_file @ %def sf_data_get_beam_file @ \subsection{Structure-function chain configuration} This is the data type that the [[process]] module uses for setting up its structure-function chain. For each structure function described by the beam data, there is an entry. The [[i]] array indicates the beam(s) to which this structure function applies, and the [[data]] object contains the actual configuration data. <>= public :: sf_config_t <>= type :: sf_config_t integer, dimension(:), allocatable :: i class(sf_data_t), allocatable :: data contains <> end type sf_config_t @ %def sf_config_t @ Output: <>= procedure :: write => sf_config_write <>= module subroutine sf_config_write (object, unit, verbose) class(sf_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine sf_config_write <>= module subroutine sf_config_write (object, unit, verbose) class(sf_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) if (allocated (object%i)) then write (u, "(1x,A,2(1x,I0))") "Structure-function configuration: & &beam(s)", object%i if (allocated (object%data)) & call object%data%write (u, verbose = verbose) else write (u, "(1x,A)") "Structure-function configuration: [undefined]" end if end subroutine sf_config_write @ %def sf_config_write @ Initialize. <>= procedure :: init => sf_config_init <>= module subroutine sf_config_init (sf_config, i_beam, sf_data) class(sf_config_t), intent(out) :: sf_config integer, dimension(:), intent(in) :: i_beam class(sf_data_t), intent(in) :: sf_data end subroutine sf_config_init <>= module subroutine sf_config_init (sf_config, i_beam, sf_data) class(sf_config_t), intent(out) :: sf_config integer, dimension(:), intent(in) :: i_beam class(sf_data_t), intent(in) :: sf_data allocate (sf_config%i (size (i_beam)), source = i_beam) allocate (sf_config%data, source = sf_data) end subroutine sf_config_init @ %def sf_config_init @ Return the PDF set, if any. <>= procedure :: get_pdf_set => sf_config_get_pdf_set <>= elemental module function sf_config_get_pdf_set (sf_config) result (pdf_set) class(sf_config_t), intent(in) :: sf_config integer :: pdf_set end function sf_config_get_pdf_set <>= elemental module function sf_config_get_pdf_set (sf_config) result (pdf_set) class(sf_config_t), intent(in) :: sf_config integer :: pdf_set pdf_set = sf_config%data%get_pdf_set () end function sf_config_get_pdf_set @ %def sf_config_get_pdf_set @ Return the beam spectrum file, if any. <>= procedure :: get_beam_file => sf_config_get_beam_file <>= module function sf_config_get_beam_file (sf_config) result (file) class(sf_config_t), intent(in) :: sf_config type(string_t) :: file end function sf_config_get_beam_file <>= module function sf_config_get_beam_file (sf_config) result (file) class(sf_config_t), intent(in) :: sf_config type(string_t) :: file file = sf_config%data%get_beam_file () end function sf_config_get_beam_file @ %def sf_config_get_beam_file @ \subsection{Structure-function instance} The [[sf_int_t]] data type contains an [[interaction_t]] object (it is an extension of this type) and a pointer to the [[sf_data_t]] configuration data. This interaction, or copies of it, is used to implement structure-function kinematics and dynamics in the context of process evaluation. The status code [[status]] tells whether the interaction is undefined, has defined kinematics (but matrix elements invalid), or is completely defined. There is also a status code for failure. The implementation is responsible for updating the status. The entries [[mi2]], [[mr2]], and [[mo2]] hold the squared invariant masses of the incoming, radiated, and outgoing particle, respectively. They are supposed to be set upon initialization, but could also be varied event by event. If the radiated or outgoing mass is nonzero, we may need to apply an on-shell projection. The projection mode is stored as [[on_shell_mode]]. The array [[beam_index]] is the list of beams on which this structure function applies ($1$, $2$, or both). The arrays [[incoming]], [[radiated]], and [[outgoing]] contain the indices of the respective particle sets within the interaction, for convenient lookup. The array [[par_index]] indicates the MC input parameters that this entry will use up in the structure-function chain. The first parameter (or the first two, for a spectrum) in this array determines the momentum fraction and is thus subject to global mappings. In the abstract base type, we do not implement the data pointer. This allows us to restrict its type in the implementations. <>= public :: sf_int_t <>= type, abstract, extends (interaction_t) :: sf_int_t integer :: status = SF_UNDEFINED real(default), dimension(:), allocatable :: mi2 real(default), dimension(:), allocatable :: mr2 real(default), dimension(:), allocatable :: mo2 integer :: on_shell_mode = KEEP_ENERGY logical :: qmin_defined = .false. logical :: qmax_defined = .false. real(default), dimension(:), allocatable :: qmin real(default), dimension(:), allocatable :: qmax integer, dimension(:), allocatable :: beam_index integer, dimension(:), allocatable :: incoming integer, dimension(:), allocatable :: radiated integer, dimension(:), allocatable :: outgoing integer, dimension(:), allocatable :: par_index integer, dimension(:), allocatable :: par_primary contains <> end type sf_int_t @ %def sf_int_t @ Status codes. The codes that refer to links, masks, and connections, apply to structure-function chains only. The status codes are public. <>= integer, parameter, public :: SF_UNDEFINED = 0 integer, parameter, public :: SF_INITIAL = 1 integer, parameter, public :: SF_DONE_LINKS = 2 integer, parameter, public :: SF_FAILED_MASK = 3 integer, parameter, public :: SF_DONE_MASK = 4 integer, parameter, public :: SF_FAILED_CONNECTIONS = 5 integer, parameter, public :: SF_DONE_CONNECTIONS = 6 integer, parameter, public :: SF_SEED_KINEMATICS = 10 integer, parameter, public :: SF_FAILED_KINEMATICS = 11 integer, parameter, public :: SF_DONE_KINEMATICS = 12 integer, parameter, public :: SF_FAILED_EVALUATION = 13 integer, parameter, public :: SF_EVALUATED = 20 @ %def SF_UNDEFINED SF_INITIAL @ %def SF_DONE_LINKS SF_DONE_MASK SF_DONE_CONNECTIONS @ %def SF_DONE_KINEMATICS SF_EVALUATED @ %def SF_FAILED_MASK SF_FAILED_CONNECTIONS @ %def SF_FAILED_KINEMATICS SF_FAILED_EVALUATION @ Write a string version of the status code: <>= subroutine write_sf_status (status, u) integer, intent(in) :: status integer, intent(in) :: u select case (status) case (SF_UNDEFINED) write (u, "(1x,'[',A,']')") "undefined" case (SF_INITIAL) write (u, "(1x,'[',A,']')") "initialized" case (SF_DONE_LINKS) write (u, "(1x,'[',A,']')") "links set" case (SF_FAILED_MASK) write (u, "(1x,'[',A,']')") "mask mismatch" case (SF_DONE_MASK) write (u, "(1x,'[',A,']')") "mask set" case (SF_FAILED_CONNECTIONS) write (u, "(1x,'[',A,']')") "connections failed" case (SF_DONE_CONNECTIONS) write (u, "(1x,'[',A,']')") "connections set" case (SF_SEED_KINEMATICS) write (u, "(1x,'[',A,']')") "incoming momenta set" case (SF_FAILED_KINEMATICS) write (u, "(1x,'[',A,']')") "kinematics failed" case (SF_DONE_KINEMATICS) write (u, "(1x,'[',A,']')") "kinematics set" case (SF_FAILED_EVALUATION) write (u, "(1x,'[',A,']')") "evaluation failed" case (SF_EVALUATED) write (u, "(1x,'[',A,']')") "evaluated" end select end subroutine write_sf_status @ %def write_sf_status @ This is the basic output routine. Display status and interaction. <>= procedure :: base_write => sf_int_base_write <>= module subroutine sf_int_base_write (object, unit, testflag) class(sf_int_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine sf_int_base_write <>= module subroutine sf_int_base_write (object, unit, testflag) class(sf_int_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)", advance="no") "SF instance:" call write_sf_status (object%status, u) if (allocated (object%beam_index)) & write (u, "(3x,A,2(1x,I0))") "beam =", object%beam_index if (allocated (object%incoming)) & write (u, "(3x,A,2(1x,I0))") "incoming =", object%incoming if (allocated (object%radiated)) & write (u, "(3x,A,2(1x,I0))") "radiated =", object%radiated if (allocated (object%outgoing)) & write (u, "(3x,A,2(1x,I0))") "outgoing =", object%outgoing if (allocated (object%par_index)) & write (u, "(3x,A,2(1x,I0))") "parameter =", object%par_index if (object%qmin_defined) & write (u, "(3x,A,1x," // FMT_19 // ")") "q_min =", object%qmin if (object%qmax_defined) & write (u, "(3x,A,1x," // FMT_19 // ")") "q_max =", object%qmax call object%interaction_t%basic_write (u, testflag = testflag) end subroutine sf_int_base_write @ %def sf_int_base_write @ The type string identifies the structure function class, and possibly more details about the structure function. <>= procedure (sf_int_type_string), deferred :: type_string <>= abstract interface function sf_int_type_string (object) result (string) import class(sf_int_t), intent(in) :: object type(string_t) :: string end function sf_int_type_string end interface @ %def sf_int_type_string @ Output of the concrete object. We should not forget to call the output routine for the base type. <>= procedure (sf_int_write), deferred :: write <>= abstract interface subroutine sf_int_write (object, unit, testflag) import class(sf_int_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine sf_int_write end interface @ %def sf_int_write @ Basic initialization: set the invariant masses for the particles and initialize the interaction. The caller should then add states to the interaction and freeze it. The dimension of the mask should be equal to the sum of the dimensions of the mass-squared arrays, which determine incoming, radiated, and outgoing particles, respectively. Optionally, we can define minimum and maximum values for the momentum transfer to the outgoing particle(s). If all masses are zero, this is actually required for non-collinear splitting. <>= procedure :: base_init => sf_int_base_init <>= module subroutine sf_int_base_init & (sf_int, mask, mi2, mr2, mo2, qmin, qmax, hel_lock) class(sf_int_t), intent(out) :: sf_int type (quantum_numbers_mask_t), dimension(:), intent(in) :: mask real(default), dimension(:), intent(in) :: mi2, mr2, mo2 real(default), dimension(:), intent(in), optional :: qmin, qmax integer, dimension(:), intent(in), optional :: hel_lock end subroutine sf_int_base_init <>= module subroutine sf_int_base_init & (sf_int, mask, mi2, mr2, mo2, qmin, qmax, hel_lock) class(sf_int_t), intent(out) :: sf_int type (quantum_numbers_mask_t), dimension(:), intent(in) :: mask real(default), dimension(:), intent(in) :: mi2, mr2, mo2 real(default), dimension(:), intent(in), optional :: qmin, qmax integer, dimension(:), intent(in), optional :: hel_lock allocate (sf_int%mi2 (size (mi2))) sf_int%mi2 = mi2 allocate (sf_int%mr2 (size (mr2))) sf_int%mr2 = mr2 allocate (sf_int%mo2 (size (mo2))) sf_int%mo2 = mo2 if (present (qmin)) then sf_int%qmin_defined = .true. allocate (sf_int%qmin (size (qmin))) sf_int%qmin = qmin end if if (present (qmax)) then sf_int%qmax_defined = .true. allocate (sf_int%qmax (size (qmax))) sf_int%qmax = qmax end if call sf_int%interaction_t%basic_init & (size (mi2), 0, size (mr2) + size (mo2), & mask = mask, hel_lock = hel_lock, set_relations = .true.) end subroutine sf_int_base_init @ %def sf_int_base_init @ Set the indices of the incoming, radiated, and outgoing particles, respectively. <>= procedure :: set_incoming => sf_int_set_incoming procedure :: set_radiated => sf_int_set_radiated procedure :: set_outgoing => sf_int_set_outgoing <>= module subroutine sf_int_set_incoming (sf_int, incoming) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: incoming end subroutine sf_int_set_incoming module subroutine sf_int_set_radiated (sf_int, radiated) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: radiated end subroutine sf_int_set_radiated module subroutine sf_int_set_outgoing (sf_int, outgoing) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: outgoing end subroutine sf_int_set_outgoing <>= module subroutine sf_int_set_incoming (sf_int, incoming) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: incoming allocate (sf_int%incoming (size (incoming))) sf_int%incoming = incoming end subroutine sf_int_set_incoming module subroutine sf_int_set_radiated (sf_int, radiated) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: radiated allocate (sf_int%radiated (size (radiated))) sf_int%radiated = radiated end subroutine sf_int_set_radiated module subroutine sf_int_set_outgoing (sf_int, outgoing) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: outgoing allocate (sf_int%outgoing (size (outgoing))) sf_int%outgoing = outgoing end subroutine sf_int_set_outgoing @ %def sf_int_set_incoming @ %def sf_int_set_radiated @ %def sf_int_set_outgoing @ Initialization. This proceeds via an abstract data object, which for the actual implementation should have the matching concrete type. Since all implementations have the same signature, we can prepare a deferred procedure. The data object will become the target of a corresponding pointer within the [[sf_int_t]] implementation. This should call the previous procedure. <>= procedure (sf_int_init), deferred :: init <>= abstract interface subroutine sf_int_init (sf_int, data) import class(sf_int_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data end subroutine sf_int_init end interface @ %def sf_int_init @ Complete initialization. This routine contains initializations that can only be performed after the interaction object got its final shape, i.e., redundant helicities have been eliminated by matching with beams and process. The default implementation does nothing. The [[target]] attribute is formally required since some overriding implementations use a temporary pointer (iterator) to the state-matrix component. It doesn't appear to make a real difference, though. <>= procedure :: setup_constants => sf_int_setup_constants <>= module subroutine sf_int_setup_constants (sf_int) class(sf_int_t), intent(inout), target :: sf_int end subroutine sf_int_setup_constants <>= module subroutine sf_int_setup_constants (sf_int) class(sf_int_t), intent(inout), target :: sf_int end subroutine sf_int_setup_constants @ %def sf_int_setup_constants @ Set beam indices, i.e., the beam(s) on which this structure function applies. <>= procedure :: set_beam_index => sf_int_set_beam_index <>= module subroutine sf_int_set_beam_index (sf_int, beam_index) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: beam_index end subroutine sf_int_set_beam_index <>= module subroutine sf_int_set_beam_index (sf_int, beam_index) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: beam_index allocate (sf_int%beam_index (size (beam_index))) sf_int%beam_index = beam_index end subroutine sf_int_set_beam_index @ %def sf_int_set_beam_index @ Set parameter indices, indicating which MC input parameters are to be used for evaluating this structure function. <>= procedure :: set_par_index => sf_int_set_par_index <>= module subroutine sf_int_set_par_index (sf_int, par_index) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: par_index end subroutine sf_int_set_par_index <>= module subroutine sf_int_set_par_index (sf_int, par_index) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: par_index allocate (sf_int%par_index (size (par_index))) sf_int%par_index = par_index end subroutine sf_int_set_par_index @ %def sf_int_set_par_index @ Initialize the structure-function kinematics, setting incoming momenta. We assume that array shapes match. Three versions. The first version relies on the momenta being linked to another interaction. The second version sets the momenta explicitly. In the third version, we first compute momenta for the specified energies and store those. <>= generic :: seed_kinematics => sf_int_receive_momenta generic :: seed_kinematics => sf_int_seed_momenta generic :: seed_kinematics => sf_int_seed_energies procedure :: sf_int_receive_momenta procedure :: sf_int_seed_momenta procedure :: sf_int_seed_energies <>= module subroutine sf_int_receive_momenta (sf_int) class(sf_int_t), intent(inout) :: sf_int end subroutine sf_int_receive_momenta module subroutine sf_int_seed_momenta (sf_int, k) class(sf_int_t), intent(inout) :: sf_int type(vector4_t), dimension(:), intent(in) :: k end subroutine sf_int_seed_momenta module subroutine sf_int_seed_energies (sf_int, E) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: E type(vector4_t), dimension(:), allocatable :: k end subroutine sf_int_seed_energies <>= module subroutine sf_int_receive_momenta (sf_int) class(sf_int_t), intent(inout) :: sf_int if (sf_int%status >= SF_INITIAL) then call sf_int%receive_momenta () sf_int%status = SF_SEED_KINEMATICS end if end subroutine sf_int_receive_momenta module subroutine sf_int_seed_momenta (sf_int, k) class(sf_int_t), intent(inout) :: sf_int type(vector4_t), dimension(:), intent(in) :: k if (sf_int%status >= SF_INITIAL) then call sf_int%set_momenta (k, outgoing=.false.) sf_int%status = SF_SEED_KINEMATICS end if end subroutine sf_int_seed_momenta module subroutine sf_int_seed_energies (sf_int, E) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: E type(vector4_t), dimension(:), allocatable :: k integer :: j if (sf_int%status >= SF_INITIAL) then allocate (k (size (E))) if (all (E**2 >= sf_int%mi2)) then do j = 1, size (E) k(j) = vector4_moving (E(j), & (3-2*j) * sqrt (E(j)**2 - sf_int%mi2(j)), 3) end do call sf_int%seed_kinematics (k) end if end if end subroutine sf_int_seed_energies @ %def sf_int_seed_momenta @ %def sf_int_seed_energies @ Tell if in generator mode. By default, this is false. To be overridden where appropriate; we may refer to the [[is_generator]] method of the [[data]] component in the concrete type. <>= procedure :: is_generator => sf_int_is_generator <>= module function sf_int_is_generator (sf_int) result (flag) class(sf_int_t), intent(in) :: sf_int logical :: flag end function sf_int_is_generator <>= module function sf_int_is_generator (sf_int) result (flag) class(sf_int_t), intent(in) :: sf_int logical :: flag flag = .false. end function sf_int_is_generator @ %def sf_int_is_generator @ Generate free parameters [[r]]. Parameters are free if they do not correspond to integration parameters (i.e., are bound), but are generated by the structure function object itself. By default, all parameters are bound, and the output values of this procedure will be discarded. With free parameters, we have to override this procedure. The value [[x_free]] is the renormalization factor of the total energy that corresponds to the free parameters. If there are no free parameters, the procedure will not change its value, which starts as unity. Otherwise, the fraction is typically decreased, but may also be increased in some cases. <>= procedure :: generate_free => sf_int_generate_free <>= module subroutine sf_int_generate_free (sf_int, r, rb, x_free) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free end subroutine sf_int_generate_free <>= module subroutine sf_int_generate_free (sf_int, r, rb, x_free) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free r = 0 rb= 1 end subroutine sf_int_generate_free @ %def sf_int_generate_free @ Complete the structure-function kinematics, derived from an input parameter (array) $r$ between 0 and 1. The interaction momenta are calculated, and we return $x$ (the momentum fraction), and $f$ (the Jacobian factor for the map $r\to x$), if [[map]] is set. If the [[map]] flag is unset, $r$ and $x$ values will coincide, and $f$ will become unity. If it is set, the structure-function implementation chooses a convenient mapping from $r$ to $x$ with Jacobian $f$. In the [[inverse_kinematics]] variant, we exchange the intent of [[x]] and [[r]]. The momenta are calculated only if the optional flag [[set_momenta]] is present and set. Internal parameters of [[sf_int]] are calculated only if the optional flag [[set_x]] is present and set. Update 2018-08-22: Throughout this algorithm, we now carry [[xb]]=$1-x$ together with [[x]] values, as we did for [[r]] before. This allows us to handle unstable endpoint numerics wherever necessary. The only place where the changes actually did matter was for inverse kinematics in the ISR setup, with a very soft photon, but it might be most sensible to apply the extension with [[xb]] everywhere. <>= procedure (sf_int_complete_kinematics), deferred :: complete_kinematics procedure (sf_int_inverse_kinematics), deferred :: inverse_kinematics <>= abstract interface subroutine sf_int_complete_kinematics (sf_int, x, xb, f, r, rb, map) import class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map end subroutine sf_int_complete_kinematics end interface abstract interface subroutine sf_int_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) import class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta end subroutine sf_int_inverse_kinematics end interface @ %def sf_int_complete_kinematics @ %def sf_int_inverse_kinematics @ Single splitting: compute momenta, given $x$ input parameters. We assume that the incoming momentum is set. The status code is set to [[SF_FAILED_KINEMATICS]] if the $x$ array does not correspond to a valid momentum configuration. Otherwise, it is updated to [[SF_DONE_KINEMATICS]]. We force the outgoing particle on-shell. The on-shell projection is determined by the [[on_shell_mode]]. The radiated particle should already be on shell. <>= procedure :: split_momentum => sf_int_split_momentum <>= module subroutine sf_int_split_momentum (sf_int, x, xb) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb end subroutine sf_int_split_momentum <>= module subroutine sf_int_split_momentum (sf_int, x, xb) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb type(vector4_t) :: k type(vector4_t), dimension(2) :: q type(splitting_data_t) :: sd real(default) :: E1, E2 logical :: fail if (sf_int%status >= SF_SEED_KINEMATICS) then k = sf_int%get_momentum (1) call sd%init (k, & sf_int%mi2(1), sf_int%mr2(1), sf_int%mo2(1), & collinear = size (x) == 1) call sd%set_t_bounds (x(1), xb(1)) select case (size (x)) case (1) case (3) if (sf_int%qmax_defined) then if (sf_int%qmin_defined) then call sd%sample_t (x(2), & t0 = - sf_int%qmax(1) ** 2, t1 = - sf_int%qmin(1) ** 2) else call sd%sample_t (x(2), & t0 = - sf_int%qmax(1) ** 2) end if else if (sf_int%qmin_defined) then call sd%sample_t (x(2), t1 = - sf_int%qmin(1) ** 2) else call sd%sample_t (x(2)) end if end if call sd%sample_phi (x(3)) case default call msg_bug ("Structure function: impossible number of parameters") end select q = sd%split_momentum (k) call on_shell (q, [sf_int%mr2, sf_int%mo2], & sf_int%on_shell_mode) call sf_int%set_momenta (q, outgoing=.true.) E1 = energy (q(1)) E2 = energy (q(2)) fail = E1 < 0 .or. E2 < 0 & .or. E1 ** 2 < sf_int%mr2(1) & .or. E2 ** 2 < sf_int%mo2(1) if (fail) then sf_int%status = SF_FAILED_KINEMATICS else sf_int%status = SF_DONE_KINEMATICS end if end if end subroutine sf_int_split_momentum @ %def sf_test_split_momentum @ Pair splitting: two incoming momenta, two radiated, two outgoing. This is simple because we insist on all momenta being collinear. <>= procedure :: split_momenta => sf_int_split_momenta <>= module subroutine sf_int_split_momenta (sf_int, x, xb) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb end subroutine sf_int_split_momenta <>= module subroutine sf_int_split_momenta (sf_int, x, xb) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb type(vector4_t), dimension(2) :: k type(vector4_t), dimension(4) :: q real(default), dimension(4) :: E logical :: fail if (sf_int%status >= SF_SEED_KINEMATICS) then select case (size (x)) case (2) case default call msg_bug ("Pair structure function: recoil requested & &but not implemented yet") end select k(1) = sf_int%get_momentum (1) k(2) = sf_int%get_momentum (2) q(1:2) = xb * k q(3:4) = x * k select case (size (sf_int%mr2)) case (2) call on_shell (q, & [sf_int%mr2(1), sf_int%mr2(2), & sf_int%mo2(1), sf_int%mo2(2)], & sf_int%on_shell_mode) call sf_int%set_momenta (q, outgoing=.true.) E = energy (q) fail = any (E < 0) & .or. any (E(1:2) ** 2 < sf_int%mr2) & .or. any (E(3:4) ** 2 < sf_int%mo2) case default; call msg_bug ("split momenta: incorrect use") end select if (fail) then sf_int%status = SF_FAILED_KINEMATICS else sf_int%status = SF_DONE_KINEMATICS end if end if end subroutine sf_int_split_momenta @ %def sf_int_split_momenta @ Pair spectrum: the reduced version of the previous splitting, without radiated momenta. <>= procedure :: reduce_momenta => sf_int_reduce_momenta <>= module subroutine sf_int_reduce_momenta (sf_int, x) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x end subroutine sf_int_reduce_momenta <>= module subroutine sf_int_reduce_momenta (sf_int, x) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x type(vector4_t), dimension(2) :: k type(vector4_t), dimension(2) :: q real(default), dimension(2) :: E logical :: fail if (sf_int%status >= SF_SEED_KINEMATICS) then select case (size (x)) case (2) case default call msg_bug ("Pair spectrum: recoil requested & &but not implemented yet") end select k(1) = sf_int%get_momentum (1) k(2) = sf_int%get_momentum (2) q = x * k call on_shell (q, & [sf_int%mo2(1), sf_int%mo2(2)], & sf_int%on_shell_mode) call sf_int%set_momenta (q, outgoing=.true.) E = energy (q) fail = any (E < 0) & .or. any (E ** 2 < sf_int%mo2) if (fail) then sf_int%status = SF_FAILED_KINEMATICS else sf_int%status = SF_DONE_KINEMATICS end if end if end subroutine sf_int_reduce_momenta @ %def sf_int_reduce_momenta @ The inverse procedure: we compute the [[x]] array from the momentum configuration. In an overriding TBP, we may also set internal data that depend on this, for convenience. NOTE: Here and above, the single-particle case is treated in detail, allowing for non-collinearity and non-vanishing masses and nontrivial momentum-transfer bounds. For the pair case, we currently implement only collinear splitting and assume massless particles. This should be improved. Update 2017-08-22: recover also [[xb]], using the updated [[recover]] method of the splitting-data object. Th <>= procedure :: recover_x => sf_int_recover_x procedure :: base_recover_x => sf_int_recover_x <>= module subroutine sf_int_recover_x (sf_int, x, xb, x_free) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free end subroutine sf_int_recover_x <>= module subroutine sf_int_recover_x (sf_int, x, xb, x_free) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free type(vector4_t), dimension(:), allocatable :: k type(vector4_t), dimension(:), allocatable :: q type(splitting_data_t) :: sd if (sf_int%status >= SF_SEED_KINEMATICS) then allocate (k (sf_int%interaction_t%get_n_in ())) allocate (q (sf_int%interaction_t%get_n_out ())) k = sf_int%get_momenta (outgoing=.false.) q = sf_int%get_momenta (outgoing=.true.) select case (size (k)) case (1) call sd%init (k(1), & sf_int%mi2(1), sf_int%mr2(1), sf_int%mo2(1), & collinear = size (x) == 1) call sd%recover (k(1), q, sf_int%on_shell_mode) x(1) = sd%get_x () xb(1) = sd%get_xb () select case (size (x)) case (1) case (3) if (sf_int%qmax_defined) then if (sf_int%qmin_defined) then call sd%inverse_t (x(2), & t0 = - sf_int%qmax(1) ** 2, t1 = - sf_int%qmin(1) ** 2) else call sd%inverse_t (x(2), & t0 = - sf_int%qmax(1) ** 2) end if else if (sf_int%qmin_defined) then call sd%inverse_t (x(2), t1 = - sf_int%qmin(1) ** 2) else call sd%inverse_t (x(2)) end if end if call sd%inverse_phi (x(3)) xb(2:3) = 1 - x(2:3) case default call msg_bug ("Structure function: impossible number & &of parameters") end select case (2) select case (size (x)) case (2) case default call msg_bug ("Pair structure function: recoil requested & &but not implemented yet") end select select case (sf_int%on_shell_mode) case (KEEP_ENERGY) select case (size (q)) case (4) x = energy (q(3:4)) / energy (k) xb= energy (q(1:2)) / energy (k) case (2) x = energy (q) / energy (k) xb= 1 - x end select case (KEEP_MOMENTUM) select case (size (q)) case (4) x = longitudinal_part (q(3:4)) / longitudinal_part (k) xb= longitudinal_part (q(1:2)) / longitudinal_part (k) case (2) x = longitudinal_part (q) / longitudinal_part (k) xb= 1 - x end select end select end select end if end subroutine sf_int_recover_x @ %def sf_int_recover_x @ Apply the structure function, i.e., evaluate the interaction. For the calculation, we may use the stored momenta, any further information stored inside the [[sf_int]] implementation during kinematics setup, and the given energy scale. It may happen that for the given kinematics the value is not defined. This should be indicated by the status code. <>= procedure (sf_int_apply), deferred :: apply <>= abstract interface subroutine sf_int_apply (sf_int, scale, negative_sf, rescale, i_sub) import class(sf_int_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub end subroutine sf_int_apply end interface @ %def sf_int_apply @ \subsection{Accessing the structure function} Return metadata. Once [[interaction_t]] is rewritten in OO, some of this will be inherited. The number of outgoing particles is equal to the number of incoming particles. The radiated particles are the difference. <>= procedure :: get_n_in => sf_int_get_n_in procedure :: get_n_rad => sf_int_get_n_rad procedure :: get_n_out => sf_int_get_n_out <>= pure module function sf_int_get_n_in (object) result (n_in) class(sf_int_t), intent(in) :: object integer :: n_in end function sf_int_get_n_in pure module function sf_int_get_n_rad (object) result (n_rad) class(sf_int_t), intent(in) :: object integer :: n_rad end function sf_int_get_n_rad pure module function sf_int_get_n_out (object) result (n_out) class(sf_int_t), intent(in) :: object integer :: n_out end function sf_int_get_n_out <>= pure module function sf_int_get_n_in (object) result (n_in) class(sf_int_t), intent(in) :: object integer :: n_in n_in = object%interaction_t%get_n_in () end function sf_int_get_n_in pure module function sf_int_get_n_rad (object) result (n_rad) class(sf_int_t), intent(in) :: object integer :: n_rad n_rad = object%interaction_t%get_n_out () & - object%interaction_t%get_n_in () end function sf_int_get_n_rad pure module function sf_int_get_n_out (object) result (n_out) class(sf_int_t), intent(in) :: object integer :: n_out n_out = object%interaction_t%get_n_in () end function sf_int_get_n_out @ %def sf_int_get_n_in @ %def sf_int_get_n_rad @ %def sf_int_get_n_out @ Number of matrix element entries in the interaction: <>= procedure :: get_n_states => sf_int_get_n_states <>= module function sf_int_get_n_states (sf_int) result (n_states) class(sf_int_t), intent(in) :: sf_int integer :: n_states end function sf_int_get_n_states <>= module function sf_int_get_n_states (sf_int) result (n_states) class(sf_int_t), intent(in) :: sf_int integer :: n_states n_states = sf_int%get_n_matrix_elements () end function sf_int_get_n_states @ %def sf_int_get_n_states @ Return a specific state as a quantum-number array. <>= procedure :: get_state => sf_int_get_state <>= module function sf_int_get_state (sf_int, i) result (qn) class(sf_int_t), intent(in) :: sf_int type(quantum_numbers_t), dimension(:), allocatable :: qn integer, intent(in) :: i end function sf_int_get_state <>= module function sf_int_get_state (sf_int, i) result (qn) class(sf_int_t), intent(in) :: sf_int type(quantum_numbers_t), dimension(:), allocatable :: qn integer, intent(in) :: i allocate (qn (sf_int%get_n_tot ())) qn = sf_int%get_quantum_numbers (i) end function sf_int_get_state @ %def sf_int_get_state @ Return the matrix-element values for all states. We can assume that the matrix elements are real, so we take the real part. <>= procedure :: get_values => sf_int_get_values <>= module subroutine sf_int_get_values (sf_int, value) class(sf_int_t), intent(in) :: sf_int real(default), dimension(:), intent(out) :: value end subroutine sf_int_get_values <>= module subroutine sf_int_get_values (sf_int, value) class(sf_int_t), intent(in) :: sf_int real(default), dimension(:), intent(out) :: value integer :: i if (sf_int%status >= SF_EVALUATED) then do i = 1, size (value) value(i) = real (sf_int%get_matrix_element (i)) end do else value = 0 end if end subroutine sf_int_get_values @ %def sf_int_get_values @ \subsection{Direct calculations} Compute a structure function value (array) directly, given an array of $x$ values and a scale. If the energy is also given, we initialize the kinematics for that energy, otherwise take it from a previous run. We assume that the [[E]] array has dimension [[n_in]], and the [[x]] array has [[n_par]]. Note: the output x values ([[xx]] and [[xxb]]) are unused in this use case. <>= procedure :: compute_values => sf_int_compute_values <>= module subroutine sf_int_compute_values (sf_int, value, x, xb, scale, E) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: value real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(in) :: scale real(default), dimension(:), intent(in), optional :: E end subroutine sf_int_compute_values <>= module subroutine sf_int_compute_values (sf_int, value, x, xb, scale, E) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: value real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(in) :: scale real(default), dimension(:), intent(in), optional :: E real(default), dimension(size (x)) :: xx, xxb real(default) :: f if (present (E)) call sf_int%seed_kinematics (E) if (sf_int%status >= SF_SEED_KINEMATICS) then call sf_int%complete_kinematics (xx, xxb, f, x, xb, map=.false.) call sf_int%apply (scale) call sf_int%get_values (value) value = value * f else value = 0 end if end subroutine sf_int_compute_values @ %def sf_int_compute_values @ Compute just a single value for one of the states, i.e., throw the others away. <>= procedure :: compute_value => sf_int_compute_value <>= module subroutine sf_int_compute_value & (sf_int, i_state, value, x, xb, scale, E) class(sf_int_t), intent(inout) :: sf_int integer, intent(in) :: i_state real(default), intent(out) :: value real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(in) :: scale real(default), dimension(:), intent(in), optional :: E end subroutine sf_int_compute_value <>= module subroutine sf_int_compute_value & (sf_int, i_state, value, x, xb, scale, E) class(sf_int_t), intent(inout) :: sf_int integer, intent(in) :: i_state real(default), intent(out) :: value real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(in) :: scale real(default), dimension(:), intent(in), optional :: E real(default), dimension(:), allocatable :: value_array if (sf_int%status >= SF_INITIAL) then allocate (value_array (sf_int%get_n_states ())) call sf_int%compute_values (value_array, x, xb, scale, E) value = value_array(i_state) else value = 0 end if end subroutine sf_int_compute_value @ %def sf_int_compute_value @ \subsection{Structure-function instance} This is a wrapper for [[sf_int_t]] objects, such that we can build an array with different structure-function types. The structure-function contains an array (a sequence) of [[sf_int_t]] objects. The object, it holds the evaluator that connects the preceding part of the structure-function chain to the current interaction. It also stores the input and output parameter values for the contained structure function. The [[r]] array has a second dimension, corresponding to the mapping channels in a multi-channel configuration. There is a Jacobian entry [[f]] for each channel. The corresponding logical array [[mapping]] tells whether we apply the mapping appropriate for the current structure function in this channel. The [[x]] parameter values (energy fractions) are common to all channels. <>= type :: sf_instance_t class(sf_int_t), allocatable :: int type(evaluator_t) :: eval real(default), dimension(:,:), allocatable :: r real(default), dimension(:,:), allocatable :: rb real(default), dimension(:), allocatable :: f logical, dimension(:), allocatable :: m real(default), dimension(:), allocatable :: x real(default), dimension(:), allocatable :: xb end type sf_instance_t @ %def sf_instance_t @ \subsection{Structure-function chain} A chain is an array of structure functions [[sf]], initiated by a beam setup. We do not use this directly for evaluation, but create instances with copies of the contained interactions. [[n_par]] is the total number of parameters that is necessary for completely determining the structure-function chain. [[n_bound]] is the number of MC input parameters that are requested from the integrator. The difference of [[n_par]] and [[n_bound]] is the number of free parameters, which are generated by a structure-function object in generator mode. <>= public :: sf_chain_t <>= type, extends (beam_t) :: sf_chain_t type(beam_data_t), pointer :: beam_data => null () integer :: n_in = 0 integer :: n_strfun = 0 integer :: n_par = 0 integer :: n_bound = 0 type(sf_instance_t), dimension(:), allocatable :: sf logical :: trace_enable = .false. integer :: trace_unit = 0 contains <> end type sf_chain_t @ %def sf_chain_t @ Finalizer. <>= procedure :: final => sf_chain_final <>= module subroutine sf_chain_final (object) class(sf_chain_t), intent(inout) :: object end subroutine sf_chain_final <>= module subroutine sf_chain_final (object) class(sf_chain_t), intent(inout) :: object integer :: i call object%final_tracing () if (allocated (object%sf)) then do i = 1, size (object%sf, 1) associate (sf => object%sf(i)) if (allocated (sf%int)) then call sf%int%final () end if end associate end do end if call beam_final (object%beam_t) end subroutine sf_chain_final @ %def sf_chain_final @ Output. <>= procedure :: write => sf_chain_write <>= module subroutine sf_chain_write (object, unit) class(sf_chain_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine sf_chain_write <>= module subroutine sf_chain_write (object, unit) class(sf_chain_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1x,A)") "Incoming particles / structure-function chain:" if (associated (object%beam_data)) then write (u, "(3x,A,I0)") "n_in = ", object%n_in write (u, "(3x,A,I0)") "n_strfun = ", object%n_strfun write (u, "(3x,A,I0)") "n_par = ", object%n_par if (object%n_par /= object%n_bound) then write (u, "(3x,A,I0)") "n_bound = ", object%n_bound end if call object%beam_data%write (u) call write_separator (u) call beam_write (object%beam_t, u) if (allocated (object%sf)) then do i = 1, object%n_strfun associate (sf => object%sf(i)) call write_separator (u) if (allocated (sf%int)) then call sf%int%write (u) else write (u, "(1x,A)") "SF instance: [undefined]" end if end associate end do end if else write (u, "(3x,A)") "[undefined]" end if end subroutine sf_chain_write @ %def sf_chain_write @ Initialize: setup beams. The [[beam_data]] target must remain valid for the lifetime of the chain, since we just establish a pointer. The structure-function configuration array is used to initialize the individual structure-function entries. The target attribute is needed because the [[sf_int]] entries establish pointers to the configuration data. <>= procedure :: init => sf_chain_init <>= module subroutine sf_chain_init (sf_chain, beam_data, sf_config) class(sf_chain_t), intent(out) :: sf_chain type(beam_data_t), intent(in), target :: beam_data type(sf_config_t), dimension(:), intent(in), optional, target :: sf_config end subroutine sf_chain_init <>= module subroutine sf_chain_init (sf_chain, beam_data, sf_config) class(sf_chain_t), intent(out) :: sf_chain type(beam_data_t), intent(in), target :: beam_data type(sf_config_t), dimension(:), intent(in), optional, target :: sf_config integer :: i sf_chain%beam_data => beam_data sf_chain%n_in = beam_data%get_n_in () call beam_init (sf_chain%beam_t, beam_data) if (present (sf_config)) then sf_chain%n_strfun = size (sf_config) allocate (sf_chain%sf (sf_chain%n_strfun)) do i = 1, sf_chain%n_strfun call sf_chain%set_strfun (i, sf_config(i)%i, sf_config(i)%data) end do end if end subroutine sf_chain_init @ %def sf_chain_init @ Receive the beam momenta from a source to which the beam interaction is linked. <>= procedure :: receive_beam_momenta => sf_chain_receive_beam_momenta <>= module subroutine sf_chain_receive_beam_momenta (sf_chain) class(sf_chain_t), intent(inout), target :: sf_chain type(interaction_t), pointer :: beam_int end subroutine sf_chain_receive_beam_momenta <>= module subroutine sf_chain_receive_beam_momenta (sf_chain) class(sf_chain_t), intent(inout), target :: sf_chain type(interaction_t), pointer :: beam_int beam_int => sf_chain%get_beam_int_ptr () call beam_int%receive_momenta () end subroutine sf_chain_receive_beam_momenta @ %def sf_chain_receive_beam_momenta @ Explicitly set the beam momenta. <>= procedure :: set_beam_momenta => sf_chain_set_beam_momenta <>= module subroutine sf_chain_set_beam_momenta (sf_chain, p) class(sf_chain_t), intent(inout) :: sf_chain type(vector4_t), dimension(:), intent(in) :: p end subroutine sf_chain_set_beam_momenta <>= module subroutine sf_chain_set_beam_momenta (sf_chain, p) class(sf_chain_t), intent(inout) :: sf_chain type(vector4_t), dimension(:), intent(in) :: p call beam_set_momenta (sf_chain%beam_t, p) end subroutine sf_chain_set_beam_momenta @ %def sf_chain_set_beam_momenta @ Set a structure-function entry. We use the [[data]] input to allocate the [[int]] structure-function instance with appropriate type, then initialize the entry. The entry establishes a pointer to [[data]]. The index [[i]] is the structure-function index in the chain. <>= procedure :: set_strfun => sf_chain_set_strfun <>= module subroutine sf_chain_set_strfun (sf_chain, i, beam_index, data) class(sf_chain_t), intent(inout) :: sf_chain integer, intent(in) :: i integer, dimension(:), intent(in) :: beam_index class(sf_data_t), intent(in), target :: data end subroutine sf_chain_set_strfun <>= module subroutine sf_chain_set_strfun (sf_chain, i, beam_index, data) class(sf_chain_t), intent(inout) :: sf_chain integer, intent(in) :: i integer, dimension(:), intent(in) :: beam_index class(sf_data_t), intent(in), target :: data integer :: n_par, j n_par = data%get_n_par () call data%allocate_sf_int (sf_chain%sf(i)%int) associate (sf_int => sf_chain%sf(i)%int) call sf_int%init (data) call sf_int%set_beam_index (beam_index) call sf_int%set_par_index & ([(j, j = sf_chain%n_par + 1, sf_chain%n_par + n_par)]) sf_chain%n_par = sf_chain%n_par + n_par if (.not. data%is_generator ()) then sf_chain%n_bound = sf_chain%n_bound + n_par end if end associate end subroutine sf_chain_set_strfun @ %def sf_chain_set_strfun @ Return the number of structure-function parameters. <>= procedure :: get_n_par => sf_chain_get_n_par procedure :: get_n_bound => sf_chain_get_n_bound <>= module function sf_chain_get_n_par (sf_chain) result (n) class(sf_chain_t), intent(in) :: sf_chain integer :: n end function sf_chain_get_n_par module function sf_chain_get_n_bound (sf_chain) result (n) class(sf_chain_t), intent(in) :: sf_chain integer :: n end function sf_chain_get_n_bound <>= module function sf_chain_get_n_par (sf_chain) result (n) class(sf_chain_t), intent(in) :: sf_chain integer :: n n = sf_chain%n_par end function sf_chain_get_n_par module function sf_chain_get_n_bound (sf_chain) result (n) class(sf_chain_t), intent(in) :: sf_chain integer :: n n = sf_chain%n_bound end function sf_chain_get_n_bound @ %def sf_chain_get_n_par @ %def sf_chain_get_n_bound @ Return a pointer to the beam interaction. <>= procedure :: get_beam_int_ptr => sf_chain_get_beam_int_ptr <>= module function sf_chain_get_beam_int_ptr (sf_chain) result (int) type(interaction_t), pointer :: int class(sf_chain_t), intent(in), target :: sf_chain end function sf_chain_get_beam_int_ptr <>= module function sf_chain_get_beam_int_ptr (sf_chain) result (int) type(interaction_t), pointer :: int class(sf_chain_t), intent(in), target :: sf_chain int => beam_get_int_ptr (sf_chain%beam_t) end function sf_chain_get_beam_int_ptr @ %def sf_chain_get_beam_int_ptr @ Enable the trace feature: record structure function data (input parameters, $x$ values, evaluation result) to an external file. <>= procedure :: setup_tracing => sf_chain_setup_tracing procedure :: final_tracing => sf_chain_final_tracing <>= module subroutine sf_chain_setup_tracing (sf_chain, file) class(sf_chain_t), intent(inout) :: sf_chain type(string_t), intent(in) :: file end subroutine sf_chain_setup_tracing module subroutine sf_chain_final_tracing (sf_chain) class(sf_chain_t), intent(inout) :: sf_chain end subroutine sf_chain_final_tracing <>= module subroutine sf_chain_setup_tracing (sf_chain, file) class(sf_chain_t), intent(inout) :: sf_chain type(string_t), intent(in) :: file if (sf_chain%n_strfun > 0) then sf_chain%trace_enable = .true. sf_chain%trace_unit = free_unit () open (sf_chain%trace_unit, file = char (file), action = "write", & status = "replace") call sf_chain%write_trace_header () else call msg_error ("Beam structure: no structure functions, tracing & &disabled") end if end subroutine sf_chain_setup_tracing module subroutine sf_chain_final_tracing (sf_chain) class(sf_chain_t), intent(inout) :: sf_chain if (sf_chain%trace_enable) then close (sf_chain%trace_unit) sf_chain%trace_enable = .false. end if end subroutine sf_chain_final_tracing @ %def sf_chain_setup_tracing @ %def sf_chain_final_tracing @ Write the header for the tracing file. <>= procedure :: write_trace_header => sf_chain_write_trace_header <>= module subroutine sf_chain_write_trace_header (sf_chain) class(sf_chain_t), intent(in) :: sf_chain end subroutine sf_chain_write_trace_header <>= module subroutine sf_chain_write_trace_header (sf_chain) class(sf_chain_t), intent(in) :: sf_chain integer :: u if (sf_chain%trace_enable) then u = sf_chain%trace_unit write (u, "('# ',A)") "WHIZARD output: & &structure-function sampling data" write (u, "('# ',A,1x,I0)") "Number of sf records:", sf_chain%n_strfun write (u, "('# ',A,1x,I0)") "Number of parameters:", sf_chain%n_par write (u, "('# ',A)") "Columns: channel, p(n_par), x(n_par), f, Jac * f" end if end subroutine sf_chain_write_trace_header @ %def sf_chain_write_trace_header @ Write a record which collects the structure function data for the current data point. For the selected channel, we print first the input integration parameters, then the $x$ values, then the structure-function value summed over all quantum numbers, then the structure function value times the mapping Jacobian. <>= procedure :: trace => sf_chain_trace <>= module subroutine sf_chain_trace (sf_chain, c_sel, p, x, f, sf_sum) class(sf_chain_t), intent(in) :: sf_chain integer, intent(in) :: c_sel real(default), dimension(:,:), intent(in) :: p real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: f real(default), intent(in) :: sf_sum end subroutine sf_chain_trace <>= module subroutine sf_chain_trace (sf_chain, c_sel, p, x, f, sf_sum) class(sf_chain_t), intent(in) :: sf_chain integer, intent(in) :: c_sel real(default), dimension(:,:), intent(in) :: p real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: f real(default), intent(in) :: sf_sum real(default) :: sf_sum_pac, f_sf_sum_pac integer :: u, i if (sf_chain%trace_enable) then u = sf_chain%trace_unit write (u, "(1x,I0)", advance="no") c_sel write (u, "(2x)", advance="no") do i = 1, sf_chain%n_par write (u, "(1x," // FMT_17 // ")", advance="no") p(i,c_sel) end do write (u, "(2x)", advance="no") do i = 1, sf_chain%n_par write (u, "(1x," // FMT_17 // ")", advance="no") x(i) end do write (u, "(2x)", advance="no") sf_sum_pac = sf_sum f_sf_sum_pac = f(c_sel) * sf_sum call pacify (sf_sum_pac, 1.E-28_default) call pacify (f_sf_sum_pac, 1.E-28_default) write (u, "(2(1x," // FMT_17 // "))") sf_sum_pac, f_sf_sum_pac end if end subroutine sf_chain_trace @ %def sf_chain_trace @ \subsection{Chain instances} A structure-function chain instance contains copies of the interactions in the configuration chain, suitably linked to each other and connected by evaluators. After initialization, [[out_sf]] should point, for each beam, to the last structure function that affects this beam. [[out_sf_i]] should indicate the index of the corresponding outgoing particle within that structure-function interaction. Analogously, [[out_eval]] is the last evaluator in the structure-function chain, which contains the complete set of outgoing particles. [[out_eval_i]] should indicate the index of the outgoing particles, within that evaluator, which will initiate the collision. When calculating actual kinematics, we fill the [[p]], [[r]], and [[x]] arrays and the [[f]] factor. The [[p]] array denotes the MC input parameters as they come from the random-number generator. The [[r]] array results from applying global mappings. The [[x]] array results from applying structure-function local mappings. The $x$ values can be interpreted directly as momentum fractions (or angle fractions, where recoil is involved). The [[f]] factor is the Jacobian that results from applying all mappings. Update 2017-08-22: carry and output all complements ([[pb]], [[rb]], [[xb]]). Previously, [[xb]] was not included in the record, and the output did not contain either. It does become more verbose, however. The [[mapping]] entry may store a global mapping that is applied to a combination of $x$ values and structure functions, as opposed to mappings that affect only a single structure function. It is applied before the latter mappings, in the transformation from the [[p]] array to the [[r]] array. For parameters affected by this mapping, we should ensure that they are not involved in a local mapping. <>= public :: sf_chain_instance_t <>= type, extends (beam_t) :: sf_chain_instance_t type(sf_chain_t), pointer :: config => null () integer :: status = SF_UNDEFINED type(sf_instance_t), dimension(:), allocatable :: sf integer, dimension(:), allocatable :: out_sf integer, dimension(:), allocatable :: out_sf_i integer :: out_eval = 0 integer, dimension(:), allocatable :: out_eval_i integer :: selected_channel = 0 real(default), dimension(:,:), allocatable :: p, pb real(default), dimension(:,:), allocatable :: r, rb real(default), dimension(:), allocatable :: f real(default), dimension(:), allocatable :: x, xb logical, dimension(:), allocatable :: bound real(default) :: x_free = 1 type(sf_channel_t), dimension(:), allocatable :: channel contains <> end type sf_chain_instance_t @ %def sf_chain_instance_t @ Finalizer. <>= procedure :: final => sf_chain_instance_final <>= module subroutine sf_chain_instance_final (object) class(sf_chain_instance_t), intent(inout) :: object end subroutine sf_chain_instance_final <>= module subroutine sf_chain_instance_final (object) class(sf_chain_instance_t), intent(inout) :: object integer :: i if (allocated (object%sf)) then do i = 1, size (object%sf, 1) associate (sf => object%sf(i)) if (allocated (sf%int)) then call sf%eval%final () call sf%int%final () end if end associate end do end if call beam_final (object%beam_t) end subroutine sf_chain_instance_final @ %def sf_chain_instance_final @ Output. <>= procedure :: write => sf_chain_instance_write <>= module subroutine sf_chain_instance_write (object, unit, col_verbose) class(sf_chain_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: col_verbose end subroutine sf_chain_instance_write <>= module subroutine sf_chain_instance_write (object, unit, col_verbose) class(sf_chain_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: col_verbose integer :: u, i, c u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "Structure-function chain instance:" call write_sf_status (object%status, u) if (allocated (object%out_sf)) then write (u, "(3x,A)", advance="no") "outgoing (interactions) =" do i = 1, size (object%out_sf) write (u, "(1x,I0,':',I0)", advance="no") & object%out_sf(i), object%out_sf_i(i) end do write (u, *) end if if (object%out_eval /= 0) then write (u, "(3x,A)", advance="no") "outgoing (evaluators) =" do i = 1, size (object%out_sf) write (u, "(1x,I0,':',I0)", advance="no") & object%out_eval, object%out_eval_i(i) end do write (u, *) end if if (allocated (object%sf)) then if (size (object%sf) /= 0) then write (u, "(1x,A)") "Structure-function parameters:" do c = 1, size (object%f) write (u, "(1x,A,I0,A)", advance="no") "Channel #", c, ":" if (c == object%selected_channel) then write (u, "(1x,A)") "[selected]" else write (u, *) end if write (u, "(3x,A,9(1x,F9.7))") "p =", object%p(:,c) write (u, "(3x,A,9(1x,F9.7))") "pb=", object%pb(:,c) write (u, "(3x,A,9(1x,F9.7))") "r =", object%r(:,c) write (u, "(3x,A,9(1x,F9.7))") "rb=", object%rb(:,c) write (u, "(3x,A,9(1x,ES13.7))") "f =", object%f(c) write (u, "(3x,A)", advance="no") "m =" call object%channel(c)%write (u) end do write (u, "(3x,A,9(1x,F9.7))") "x =", object%x write (u, "(3x,A,9(1x,F9.7))") "xb=", object%xb if (.not. all (object%bound)) then write (u, "(3x,A,9(1x,L1))") "bound =", object%bound end if end if end if call write_separator (u) call beam_write (object%beam_t, u, col_verbose = col_verbose) if (allocated (object%sf)) then do i = 1, size (object%sf) associate (sf => object%sf(i)) call write_separator (u) if (allocated (sf%int)) then if (allocated (sf%r)) then write (u, "(1x,A)") "Structure-function parameters:" do c = 1, size (sf%f) write (u, "(1x,A,I0,A)", advance="no") "Channel #", c, ":" if (c == object%selected_channel) then write (u, "(1x,A)") "[selected]" else write (u, *) end if write (u, "(3x,A,9(1x,F9.7))") "r =", sf%r(:,c) write (u, "(3x,A,9(1x,F9.7))") "rb=", sf%rb(:,c) write (u, "(3x,A,9(1x,ES13.7))") "f =", sf%f(c) write (u, "(3x,A,9(1x,L1,7x))") "m =", sf%m(c) end do write (u, "(3x,A,9(1x,F9.7))") "x =", sf%x write (u, "(3x,A,9(1x,F9.7))") "xb=", sf%xb end if call sf%int%write(u) if (.not. sf%eval%is_empty ()) then call sf%eval%write (u, col_verbose = col_verbose) end if end if end associate end do end if end subroutine sf_chain_instance_write @ %def sf_chain_instance_write @ Initialize. This creates a copy of the interactions in the configuration chain, assumed to be properly initialized. In the copy, we allocate the [[p]] etc.\ arrays. The brute-force assignment of the [[sf]] component would be straightforward, but we provide a more fine-grained copy. In any case, the copy is deep as far as allocatables are concerned, but for the contained [[interaction_t]] objects the copy is shallow, as long as we do not bind defined assignment to the type. Therefore, we have to re-assign the [[interaction_t]] components explicitly, this time calling the proper defined assignment. Furthermore, we allocate the parameter arrays for each structure function. <>= procedure :: init => sf_chain_instance_init <>= module subroutine sf_chain_instance_init (chain, config, n_channel) class(sf_chain_instance_t), intent(out), target :: chain type(sf_chain_t), intent(in), target :: config integer, intent(in) :: n_channel end subroutine sf_chain_instance_init <>= module subroutine sf_chain_instance_init (chain, config, n_channel) class(sf_chain_instance_t), intent(out), target :: chain type(sf_chain_t), intent(in), target :: config integer, intent(in) :: n_channel integer :: i, j integer :: n_par_tot, n_par, n_strfun chain%config => config n_strfun = config%n_strfun chain%beam_t = config%beam_t allocate (chain%out_sf (config%n_in), chain%out_sf_i (config%n_in)) allocate (chain%out_eval_i (config%n_in)) chain%out_sf = 0 chain%out_sf_i = [(i, i = 1, config%n_in)] chain%out_eval_i = chain%out_sf_i n_par_tot = 0 if (n_strfun /= 0) then allocate (chain%sf (n_strfun)) do i = 1, n_strfun associate (sf => chain%sf(i)) allocate (sf%int, source=config%sf(i)%int) sf%int%interaction_t = config%sf(i)%int%interaction_t n_par = size (sf%int%par_index) allocate (sf%r (n_par, n_channel)); sf%r = 0 allocate (sf%rb(n_par, n_channel)); sf%rb= 0 allocate (sf%f (n_channel)); sf%f = 0 allocate (sf%m (n_channel)); sf%m = .false. allocate (sf%x (n_par)); sf%x = 0 allocate (sf%xb(n_par)); sf%xb= 0 n_par_tot = n_par_tot + n_par end associate end do allocate (chain%p (n_par_tot, n_channel)); chain%p = 0 allocate (chain%pb(n_par_tot, n_channel)); chain%pb= 0 allocate (chain%r (n_par_tot, n_channel)); chain%r = 0 allocate (chain%rb(n_par_tot, n_channel)); chain%rb= 0 allocate (chain%f (n_channel)); chain%f = 0 allocate (chain%x (n_par_tot)); chain%x = 0 allocate (chain%xb(n_par_tot)); chain%xb= 0 call allocate_sf_channels & (chain%channel, n_channel=n_channel, n_strfun=n_strfun) end if allocate (chain%bound (n_par_tot), source = .true.) do i = 1, n_strfun associate (sf => chain%sf(i)) if (sf%int%is_generator ()) then do j = 1, size (sf%int%par_index) chain%bound(sf%int%par_index(j)) = .false. end do end if end associate end do chain%status = SF_INITIAL end subroutine sf_chain_instance_init @ %def sf_chain_instance_init @ Manually select a channel. <>= procedure :: select_channel => sf_chain_instance_select_channel <>= module subroutine sf_chain_instance_select_channel (chain, channel) class(sf_chain_instance_t), intent(inout) :: chain integer, intent(in), optional :: channel end subroutine sf_chain_instance_select_channel <>= module subroutine sf_chain_instance_select_channel (chain, channel) class(sf_chain_instance_t), intent(inout) :: chain integer, intent(in), optional :: channel if (present (channel)) then chain%selected_channel = channel else chain%selected_channel = 0 end if end subroutine sf_chain_instance_select_channel @ %def sf_chain_instance_select_channel @ Copy a channel-mapping object to the structure-function chain instance. We assume that assignment is sufficient, i.e., any non-static components of the [[channel]] object are allocatable und thus recursively copied. After the copy, we extract the single-entry mappings and activate them for the individual structure functions. If there is a multi-entry mapping, we obtain the corresponding MC parameter indices and set them in the copy of the channel object. <>= procedure :: set_channel => sf_chain_instance_set_channel <>= module subroutine sf_chain_instance_set_channel (chain, c, channel) class(sf_chain_instance_t), intent(inout) :: chain integer, intent(in) :: c type(sf_channel_t), intent(in) :: channel end subroutine sf_chain_instance_set_channel <>= module subroutine sf_chain_instance_set_channel (chain, c, channel) class(sf_chain_instance_t), intent(inout) :: chain integer, intent(in) :: c type(sf_channel_t), intent(in) :: channel integer :: i, j, k if (chain%status >= SF_INITIAL) then chain%channel(c) = channel j = 0 do i = 1, chain%config%n_strfun associate (sf => chain%sf(i)) sf%m(c) = channel%is_single_mapping (i) if (channel%is_multi_mapping (i)) then do k = 1, size (sf%int%beam_index) j = j + 1 call chain%channel(c)%set_par_index & (j, sf%int%par_index(k)) end do end if end associate end do if (j /= chain%channel(c)%get_multi_mapping_n_par ()) then print *, "index last filled = ", j print *, "number of parameters = ", & chain%channel(c)%get_multi_mapping_n_par () call msg_bug ("Structure-function setup: mapping index mismatch") end if chain%status = SF_INITIAL end if end subroutine sf_chain_instance_set_channel @ %def sf_chain_instance_set_channel @ Link the interactions in the chain. First, link the beam instance to its template in the configuration chain, which should have the appropriate momenta fixed. Then, we follow the chain via the arrays [[out_sf]] and [[out_sf_i]]. The arrays are (up to) two-dimensional, the entries correspond to the beam particle(s). For each beam, the entry [[out_sf]] points to the last interaction that affected this beam, and [[out_sf_i]] is the out-particle index within that interaction. For the initial beam, [[out_sf]] is zero by definition. For each entry in the chain, we scan the affected beams (one or two). We look for [[out_sf]] and link the out-particle there to the corresponding in-particle in the current interaction. Then, we update the entry in [[out_sf]] and [[out_sf_i]] to point to the current interaction. <>= procedure :: link_interactions => sf_chain_instance_link_interactions <>= module subroutine sf_chain_instance_link_interactions (chain) class(sf_chain_instance_t), intent(inout), target :: chain end subroutine sf_chain_instance_link_interactions <>= module subroutine sf_chain_instance_link_interactions (chain) class(sf_chain_instance_t), intent(inout), target :: chain type(interaction_t), pointer :: int integer :: i, j, b if (chain%status >= SF_INITIAL) then do b = 1, chain%config%n_in int => beam_get_int_ptr (chain%beam_t) call interaction_set_source_link_beam (int, b, & chain%config%beam_t, b) end do if (allocated (chain%sf)) then do i = 1, size (chain%sf) associate (sf_int => chain%sf(i)%int) do j = 1, size (sf_int%beam_index) b = sf_int%beam_index(j) call link (sf_int%interaction_t, b, sf_int%incoming(j)) chain%out_sf(b) = i chain%out_sf_i(b) = sf_int%outgoing(j) end do end associate end do end if chain%status = SF_DONE_LINKS end if contains subroutine link (int, b, in_index) type(interaction_t), intent(inout) :: int integer, intent(in) :: b, in_index integer :: i i = chain%out_sf(b) select case (i) case (0) call interaction_set_source_link_beam (int, in_index, & chain%beam_t, chain%out_sf_i(b)) case default call int%set_source_link (in_index, & chain%sf(i)%int, chain%out_sf_i(b)) end select end subroutine link end subroutine sf_chain_instance_link_interactions @ %def sf_chain_instance_link_interactions @ Exchange the quantum-number masks between the interactions in the chain, so we can combine redundant entries and detect any obvious mismatch. We proceed first in the forward direction and then backwards again. After this is finished, we finalize initialization by calling the [[setup_constants]] method, which prepares constant data that depend on the matrix element structure. <>= procedure :: exchange_mask => sf_chain_exchange_mask <>= module subroutine sf_chain_exchange_mask (chain) class(sf_chain_instance_t), intent(inout), target :: chain end subroutine sf_chain_exchange_mask <>= module subroutine sf_chain_exchange_mask (chain) class(sf_chain_instance_t), intent(inout), target :: chain type(interaction_t), pointer :: int type(quantum_numbers_mask_t), dimension(:), allocatable :: mask integer :: i if (chain%status >= SF_DONE_LINKS) then if (allocated (chain%sf)) then int => beam_get_int_ptr (chain%beam_t) allocate (mask (int%get_n_out ())) mask = int%get_mask () if (size (chain%sf) /= 0) then do i = 1, size (chain%sf) - 1 call chain%sf(i)%int%exchange_mask () end do do i = size (chain%sf), 1, -1 call chain%sf(i)%int%exchange_mask () end do if (any (mask .neqv. int%get_mask ())) then chain%status = SF_FAILED_MASK return end if do i = 1, size (chain%sf) call chain%sf(i)%int%setup_constants () end do end if end if chain%status = SF_DONE_MASK end if end subroutine sf_chain_exchange_mask @ %def sf_chain_exchange_mask @ Initialize the evaluators that connect the interactions in the chain. <>= procedure :: init_evaluators => sf_chain_instance_init_evaluators <>= module subroutine sf_chain_instance_init_evaluators (chain, extended_sf) class(sf_chain_instance_t), intent(inout), target :: chain logical, intent(in), optional :: extended_sf end subroutine sf_chain_instance_init_evaluators <>= module subroutine sf_chain_instance_init_evaluators (chain, extended_sf) class(sf_chain_instance_t), intent(inout), target :: chain logical, intent(in), optional :: extended_sf type(interaction_t), pointer :: int type(quantum_numbers_mask_t) :: mask integer :: i logical :: yorn yorn = .false.; if (present (extended_sf)) yorn = extended_sf if (chain%status >= SF_DONE_MASK) then if (allocated (chain%sf)) then if (size (chain%sf) /= 0) then mask = quantum_numbers_mask (.false., .false., .true.) int => beam_get_int_ptr (chain%beam_t) do i = 1, size (chain%sf) associate (sf => chain%sf(i)) if (yorn) then if (int%get_n_sub () == 0) then call int%declare_subtraction (n_beams_rescaled) end if if (sf%int%interaction_t%get_n_sub () == 0) then call sf%int%interaction_t%declare_subtraction (n_beams_rescaled) end if end if call sf%eval%init_product (int, sf%int%interaction_t, mask,& & ignore_sub_for_qn = .true.) if (sf%eval%is_empty ()) then chain%status = SF_FAILED_CONNECTIONS return end if int => sf%eval%interaction_t end associate end do call find_outgoing_particles () end if else if (chain%out_eval == 0) then int => beam_get_int_ptr (chain%beam_t) call int%tag_hard_process () end if chain%status = SF_DONE_CONNECTIONS end if contains <> end subroutine sf_chain_instance_init_evaluators @ %def sf_chain_instance_init_evaluators @ For debug purposes <>= procedure :: write_interaction => sf_chain_instance_write_interaction <>= module subroutine sf_chain_instance_write_interaction & (chain, i_sf, i_int, unit) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: i_sf, i_int integer, intent(in) :: unit end subroutine sf_chain_instance_write_interaction <>= module subroutine sf_chain_instance_write_interaction & (chain, i_sf, i_int, unit) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: i_sf, i_int integer, intent(in) :: unit class(interaction_t), pointer :: int_in1 => null () class(interaction_t), pointer :: int_in2 => null () integer :: u u = given_output_unit (unit); if (u < 0) return if (chain%status >= SF_DONE_MASK) then if (allocated (chain%sf)) then int_in1 => evaluator_get_int_in_ptr (chain%sf(i_sf)%eval, 1) int_in2 => evaluator_get_int_in_ptr (chain%sf(i_sf)%eval, 2) if (int_in1%get_tag () == i_int) then call int_in1%basic_write (u) else if (int_in2%get_tag () == i_int) then call int_in2%basic_write (u) else write (u, "(A,1x,I0,1x,A,1x,I0)") 'No tag of sf', i_sf, 'matches' , i_int end if else write (u, "(A)") 'No sf_chain allocated!' end if else write (u, "(A)") 'sf_chain not ready!' end if end subroutine sf_chain_instance_write_interaction @ %def sf_chain_instance_write_interaction @ This is an internal subroutine of the previous one: After evaluators are set, trace the outgoing particles to the last evaluator. We only need the first channel, all channels are equivalent for this purpose. For each beam, the outgoing particle is located by [[out_sf]] (the structure-function object where it originates) and [[out_sf_i]] (the index within that object). This particle is referenced by the corresponding evaluator, which in turn is referenced by the next evaluator, until we are at the end of the chain. We can trace back references by [[interaction_find_link]]. Knowing that [[out_eval]] is the index of the last evaluator, we thus determine [[out_eval_i]], the index of the outgoing particle within that evaluator. <>= subroutine find_outgoing_particles () type(interaction_t), pointer :: int, int_next integer :: i, j, out_sf, out_i chain%out_eval = size (chain%sf) do j = 1, size (chain%out_eval_i) out_sf = chain%out_sf(j) out_i = chain%out_sf_i(j) if (out_sf == 0) then int => beam_get_int_ptr (chain%beam_t) out_sf = 1 else int => chain%sf(out_sf)%int%interaction_t end if do i = out_sf, chain%out_eval int_next => chain%sf(i)%eval%interaction_t out_i = interaction_find_link (int_next, int, out_i) int => int_next end do chain%out_eval_i(j) = out_i end do call int%tag_hard_process (chain%out_eval_i) end subroutine find_outgoing_particles @ %def find_outgoing_particles @ Compute the kinematics in the chain instance. We can assume that the seed momenta are set in the configuration beams. Scanning the chain, we first transfer the incoming momenta. Then, the use up the MC input parameter array [[p]] to compute the radiated and outgoing momenta. In the multi-channel case, [[c_sel]] is the channel which we use for computing the kinematics and the [[x]] values. In the other channels, we invert the kinematics in order to recover the corresponding rows in the [[r]] array, and the Jacobian [[f]]. We first apply any global mapping to transform the input [[p]] into the array [[r]]. This is then given to the structure functions which compute the final array [[x]] and Jacobian factors [[f]], which we multiply to obtain the overall Jacobian. <>= procedure :: compute_kinematics => sf_chain_instance_compute_kinematics <>= module subroutine sf_chain_instance_compute_kinematics (chain, c_sel, p_in) class(sf_chain_instance_t), intent(inout), target :: chain integer, intent(in) :: c_sel real(default), dimension(:), intent(in) :: p_in end subroutine sf_chain_instance_compute_kinematics <>= module subroutine sf_chain_instance_compute_kinematics (chain, c_sel, p_in) class(sf_chain_instance_t), intent(inout), target :: chain integer, intent(in) :: c_sel real(default), dimension(:), intent(in) :: p_in type(interaction_t), pointer :: int real(default) :: f_mapping integer :: i, j, c if (chain%status >= SF_DONE_CONNECTIONS) then call chain%select_channel (c_sel) int => beam_get_int_ptr (chain%beam_t) call int%receive_momenta () if (allocated (chain%sf)) then if (size (chain%sf) /= 0) then forall (i = 1:size (chain%sf)) chain%sf(i)%int%status = SF_INITIAL chain%p (:,c_sel) = unpack (p_in, chain%bound, 0._default) chain%pb(:,c_sel) = 1 - chain%p(:,c_sel) chain%f = 1 chain%x_free = 1 do i = 1, size (chain%sf) associate (sf => chain%sf(i)) call sf%int%generate_free (sf%r(:,c_sel), sf%rb(:,c_sel), & chain%x_free) do j = 1, size (sf%x) if (.not. chain%bound(sf%int%par_index(j))) then chain%p (sf%int%par_index(j),c_sel) = sf%r (j,c_sel) chain%pb(sf%int%par_index(j),c_sel) = sf%rb(j,c_sel) end if end do end associate end do if (allocated (chain%channel(c_sel)%multi_mapping)) then call chain%channel(c_sel)%multi_mapping%compute & (chain%r(:,c_sel), chain%rb(:,c_sel), & f_mapping, & chain%p(:,c_sel), chain%pb(:,c_sel), & chain%x_free) chain%f(c_sel) = f_mapping else chain%r (:,c_sel) = chain%p (:,c_sel) chain%rb(:,c_sel) = chain%pb(:,c_sel) chain%f(c_sel) = 1 end if do i = 1, size (chain%sf) associate (sf => chain%sf(i)) call sf%int%seed_kinematics () do j = 1, size (sf%x) sf%r (j,c_sel) = chain%r (sf%int%par_index(j),c_sel) sf%rb(j,c_sel) = chain%rb(sf%int%par_index(j),c_sel) end do call sf%int%complete_kinematics & (sf%x, sf%xb, sf%f(c_sel), sf%r(:,c_sel), sf%rb(:,c_sel), & sf%m(c_sel)) do j = 1, size (sf%x) chain%x(sf%int%par_index(j)) = sf%x(j) chain%xb(sf%int%par_index(j)) = sf%xb(j) end do if (sf%int%status <= SF_FAILED_KINEMATICS) then chain%status = SF_FAILED_KINEMATICS return end if do c = 1, size (sf%f) if (c /= c_sel) then call sf%int%inverse_kinematics & (sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c)) do j = 1, size (sf%x) chain%r (sf%int%par_index(j),c) = sf%r (j,c) chain%rb(sf%int%par_index(j),c) = sf%rb(j,c) end do end if chain%f(c) = chain%f(c) * sf%f(c) end do if (.not. sf%eval%is_empty ()) then call sf%eval%receive_momenta () end if end associate end do do c = 1, size (chain%f) if (c /= c_sel) then if (allocated (chain%channel(c)%multi_mapping)) then call chain%channel(c)%multi_mapping%inverse & (chain%r(:,c), chain%rb(:,c), & f_mapping, & chain%p(:,c), chain%pb(:,c), & chain%x_free) chain%f(c) = chain%f(c) * f_mapping else chain%p (:,c) = chain%r (:,c) chain%pb(:,c) = chain%rb(:,c) end if end if end do end if end if chain%status = SF_DONE_KINEMATICS end if end subroutine sf_chain_instance_compute_kinematics @ %def sf_chain_instance_compute_kinematics @ This is a variant of the previous procedure. We know the $x$ parameters and reconstruct the momenta and the MC input parameters [[p]]. We do not need to select a channel. Note: this is probably redundant, since the method we actually want starts from the momenta, recovers all $x$ parameters, and then inverts mappings. See below [[recover_kinematics]]. <>= procedure :: inverse_kinematics => sf_chain_instance_inverse_kinematics <>= module subroutine sf_chain_instance_inverse_kinematics (chain, x, xb) class(sf_chain_instance_t), intent(inout), target :: chain real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb end subroutine sf_chain_instance_inverse_kinematics <>= module subroutine sf_chain_instance_inverse_kinematics (chain, x, xb) class(sf_chain_instance_t), intent(inout), target :: chain real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb type(interaction_t), pointer :: int real(default) :: f_mapping integer :: i, j, c if (chain%status >= SF_DONE_CONNECTIONS) then call chain%select_channel () int => beam_get_int_ptr (chain%beam_t) call int%receive_momenta () if (allocated (chain%sf)) then chain%f = 1 if (size (chain%sf) /= 0) then forall (i = 1:size (chain%sf)) chain%sf(i)%int%status = SF_INITIAL chain%x = x chain%xb= xb do i = 1, size (chain%sf) associate (sf => chain%sf(i)) call sf%int%seed_kinematics () do j = 1, size (sf%x) sf%x(j) = chain%x(sf%int%par_index(j)) sf%xb(j) = chain%xb(sf%int%par_index(j)) end do do c = 1, size (sf%f) call sf%int%inverse_kinematics & (sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c), & set_momenta = c==1) chain%f(c) = chain%f(c) * sf%f(c) do j = 1, size (sf%x) chain%r (sf%int%par_index(j),c) = sf%r (j,c) chain%rb(sf%int%par_index(j),c) = sf%rb(j,c) end do end do if (.not. sf%eval%is_empty ()) then call sf%eval%receive_momenta () end if end associate end do do c = 1, size (chain%f) if (allocated (chain%channel(c)%multi_mapping)) then call chain%channel(c)%multi_mapping%inverse & (chain%r(:,c), chain%rb(:,c), & f_mapping, & chain%p(:,c), chain%pb(:,c), & chain%x_free) chain%f(c) = chain%f(c) * f_mapping else chain%p (:,c) = chain%r (:,c) chain%pb(:,c) = chain%rb(:,c) end if end do end if end if chain%status = SF_DONE_KINEMATICS end if end subroutine sf_chain_instance_inverse_kinematics @ %def sf_chain_instance_inverse_kinematics @ Recover the kinematics: assuming that the last evaluator has been filled with a valid set of momenta, we travel the momentum links backwards and fill the preceding evaluators and, as a side effect, interactions. We stop at the beam interaction. After all momenta are set, apply the [[inverse_kinematics]] procedure above, suitably modified, to recover the $x$ and $p$ parameters and the Jacobian factors. The [[c_sel]] (channel) argument is just used to mark a selected channel for the records, otherwise the recovery procedure is independent of this. <>= procedure :: recover_kinematics => sf_chain_instance_recover_kinematics <>= module subroutine sf_chain_instance_recover_kinematics (chain, c_sel) class(sf_chain_instance_t), intent(inout), target :: chain integer, intent(in) :: c_sel end subroutine sf_chain_instance_recover_kinematics <>= module subroutine sf_chain_instance_recover_kinematics (chain, c_sel) class(sf_chain_instance_t), intent(inout), target :: chain integer, intent(in) :: c_sel real(default) :: f_mapping integer :: i, j, c if (chain%status >= SF_DONE_CONNECTIONS) then call chain%select_channel (c_sel) if (allocated (chain%sf)) then do i = size (chain%sf), 1, -1 associate (sf => chain%sf(i)) if (.not. sf%eval%is_empty ()) then call sf%eval%send_momenta () end if end associate end do chain%f = 1 if (size (chain%sf) /= 0) then forall (i = 1:size (chain%sf)) chain%sf(i)%int%status = SF_INITIAL chain%x_free = 1 do i = 1, size (chain%sf) associate (sf => chain%sf(i)) call sf%int%seed_kinematics () call sf%int%recover_x (sf%x, sf%xb, chain%x_free) do j = 1, size (sf%x) chain%x(sf%int%par_index(j)) = sf%x(j) chain%xb(sf%int%par_index(j)) = sf%xb(j) end do do c = 1, size (sf%f) call sf%int%inverse_kinematics & (sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c), & set_momenta = .false.) chain%f(c) = chain%f(c) * sf%f(c) do j = 1, size (sf%x) chain%r (sf%int%par_index(j),c) = sf%r (j,c) chain%rb(sf%int%par_index(j),c) = sf%rb(j,c) end do end do end associate end do do c = 1, size (chain%f) if (allocated (chain%channel(c)%multi_mapping)) then call chain%channel(c)%multi_mapping%inverse & (chain%r(:,c), chain%rb(:,c), & f_mapping, & chain%p(:,c), chain%pb(:,c), & chain%x_free) chain%f(c) = chain%f(c) * f_mapping else chain%p (:,c) = chain%r (:,c) chain%pb(:,c) = chain%rb(:,c) end if end do end if end if chain%status = SF_DONE_KINEMATICS end if end subroutine sf_chain_instance_recover_kinematics @ %def sf_chain_instance_recover_kinematics @ Return the initial beam momenta to their source, thus completing kinematics recovery. Obviously, this works as a side effect. <>= procedure :: return_beam_momenta => sf_chain_instance_return_beam_momenta <>= module subroutine sf_chain_instance_return_beam_momenta (chain) class(sf_chain_instance_t), intent(in), target :: chain type(interaction_t), pointer :: int end subroutine sf_chain_instance_return_beam_momenta <>= module subroutine sf_chain_instance_return_beam_momenta (chain) class(sf_chain_instance_t), intent(in), target :: chain type(interaction_t), pointer :: int if (chain%status >= SF_DONE_KINEMATICS) then int => beam_get_int_ptr (chain%beam_t) call int%send_momenta () end if end subroutine sf_chain_instance_return_beam_momenta @ %def sf_chain_instance_return_beam_momenta @ Evaluate all interactions in the chain and the product evaluators. We provide a [[scale]] argument that is given to all structure functions in the chain. Hadronic NLO calculations involve rescaled fractions of the original beam momentum. In particular, we have to handle the following cases: \begin{itemize} \item normal evaluation (where [[i_sub = 0]]) for all terms except the real non-subtracted, \item rescaled momentum fraction for both beams in the case of the real non-subtracted term ([[i_sub = 0]]), \item and rescaled momentum fraction for one of both beams in the case of the subtraction and DGLAP component ([[i_sub = 1,2]]). \end{itemize} For the collinear final or intial state counter terms, we apply a rescaling to one beam, and keep the other beam as is. We redo it then vice versa having now two subtractions. <>= procedure :: evaluate => sf_chain_instance_evaluate <>= module subroutine sf_chain_instance_evaluate & (chain, scale, negative_sf, sf_rescale) class(sf_chain_instance_t), intent(inout), target :: chain real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(inout), optional :: sf_rescale end subroutine sf_chain_instance_evaluate <>= module subroutine sf_chain_instance_evaluate & (chain, scale, negative_sf, sf_rescale) class(sf_chain_instance_t), intent(inout), target :: chain real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(inout), optional :: sf_rescale type(interaction_t), pointer :: out_int real(default) :: sf_sum integer :: i_beam, i_sub, n_sub logical :: rescale n_sub = 0 rescale = .false.; if (present (sf_rescale)) rescale = .true. if (rescale) then n_sub = chain%get_n_sub () end if if (chain%status >= SF_DONE_KINEMATICS) then if (allocated (chain%sf)) then if (size (chain%sf) /= 0) then do i_beam = 1, size (chain%sf) associate (sf => chain%sf(i_beam)) if (rescale) then call sf_rescale%set_i_beam (i_beam) do i_sub = 0, n_sub select case (i_sub) case (0) if (n_sub == 0) then call sf%int%apply (scale, negative_sf, sf_rescale, i_sub = i_sub) else call sf%int%apply (scale, negative_sf, i_sub = i_sub) end if case default if (i_beam == i_sub) then call sf%int%apply (scale, negative_sf, sf_rescale, i_sub = i_sub) else call sf%int%apply (scale, negative_sf, i_sub = i_sub) end if end select end do else call sf%int%apply (scale, negative_sf, i_sub = n_sub) end if if (sf%int%status <= SF_FAILED_EVALUATION) then chain%status = SF_FAILED_EVALUATION return end if if (.not. sf%eval%is_empty ()) call sf%eval%evaluate () end associate end do out_int => chain%get_out_int_ptr () sf_sum = real (out_int%sum ()) call chain%config%trace & (chain%selected_channel, chain%p, chain%x, chain%f, sf_sum) end if end if chain%status = SF_EVALUATED end if end subroutine sf_chain_instance_evaluate @ %def sf_chain_instance_evaluate @ \subsection{Access to the chain instance} Transfer the outgoing momenta to the array [[p]]. We assume that array sizes match. <>= procedure :: get_out_momenta => sf_chain_instance_get_out_momenta <>= module subroutine sf_chain_instance_get_out_momenta (chain, p) class(sf_chain_instance_t), intent(in), target :: chain type(vector4_t), dimension(:), intent(out) :: p end subroutine sf_chain_instance_get_out_momenta <>= module subroutine sf_chain_instance_get_out_momenta (chain, p) class(sf_chain_instance_t), intent(in), target :: chain type(vector4_t), dimension(:), intent(out) :: p type(interaction_t), pointer :: int integer :: i, j if (chain%status >= SF_DONE_KINEMATICS) then do j = 1, size (chain%out_sf) i = chain%out_sf(j) select case (i) case (0) int => beam_get_int_ptr (chain%beam_t) case default int => chain%sf(i)%int%interaction_t end select p(j) = int%get_momentum (chain%out_sf_i(j)) end do end if end subroutine sf_chain_instance_get_out_momenta @ %def sf_chain_instance_get_out_momenta @ Return a pointer to the last evaluator in the chain (to the interaction). <>= procedure :: get_out_int_ptr => sf_chain_instance_get_out_int_ptr <>= module function sf_chain_instance_get_out_int_ptr (chain) result (int) class(sf_chain_instance_t), intent(in), target :: chain type(interaction_t), pointer :: int end function sf_chain_instance_get_out_int_ptr <>= module function sf_chain_instance_get_out_int_ptr (chain) result (int) class(sf_chain_instance_t), intent(in), target :: chain type(interaction_t), pointer :: int if (chain%out_eval == 0) then int => beam_get_int_ptr (chain%beam_t) else int => chain%sf(chain%out_eval)%eval%interaction_t end if end function sf_chain_instance_get_out_int_ptr @ %def sf_chain_instance_get_out_int_ptr @ Return the index of the [[j]]-th outgoing particle, within the last evaluator. <>= procedure :: get_out_i => sf_chain_instance_get_out_i <>= module function sf_chain_instance_get_out_i (chain, j) result (i) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: j integer :: i end function sf_chain_instance_get_out_i <>= module function sf_chain_instance_get_out_i (chain, j) result (i) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: j integer :: i i = chain%out_eval_i(j) end function sf_chain_instance_get_out_i @ %def sf_chain_instance_get_out_i @ Return the mask for the outgoing particle(s), within the last evaluator. <>= procedure :: get_out_mask => sf_chain_instance_get_out_mask <>= module function sf_chain_instance_get_out_mask (chain) result (mask) class(sf_chain_instance_t), intent(in), target :: chain type(quantum_numbers_mask_t), dimension(:), allocatable :: mask end function sf_chain_instance_get_out_mask <>= module function sf_chain_instance_get_out_mask (chain) result (mask) class(sf_chain_instance_t), intent(in), target :: chain type(quantum_numbers_mask_t), dimension(:), allocatable :: mask type(interaction_t), pointer :: int allocate (mask (chain%config%n_in)) int => chain%get_out_int_ptr () mask = int%get_mask (chain%out_eval_i) end function sf_chain_instance_get_out_mask @ %def sf_chain_instance_get_out_mask @ Return the array of MC input parameters that corresponds to channel [[c]]. This is the [[p]] array, the parameters before all mappings. The [[p]] array may be deallocated. This should correspond to a zero-size [[r]] argument, so nothing to do then. <>= procedure :: get_mcpar => sf_chain_instance_get_mcpar <>= module subroutine sf_chain_instance_get_mcpar (chain, c, r) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: c real(default), dimension(:), intent(out) :: r end subroutine sf_chain_instance_get_mcpar <>= module subroutine sf_chain_instance_get_mcpar (chain, c, r) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: c real(default), dimension(:), intent(out) :: r if (allocated (chain%p)) r = pack (chain%p(:,c), chain%bound) end subroutine sf_chain_instance_get_mcpar @ %def sf_chain_instance_get_mcpar @ Return the Jacobian factor that corresponds to channel [[c]]. <>= procedure :: get_f => sf_chain_instance_get_f <>= module function sf_chain_instance_get_f (chain, c) result (f) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: c real(default) :: f end function sf_chain_instance_get_f <>= module function sf_chain_instance_get_f (chain, c) result (f) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: c real(default) :: f if (allocated (chain%f)) then f = chain%f(c) else f = 1 end if end function sf_chain_instance_get_f @ %def sf_chain_instance_get_f @ Return the evaluation status. <>= procedure :: get_status => sf_chain_instance_get_status <>= module function sf_chain_instance_get_status (chain) result (status) class(sf_chain_instance_t), intent(in) :: chain integer :: status end function sf_chain_instance_get_status <>= module function sf_chain_instance_get_status (chain) result (status) class(sf_chain_instance_t), intent(in) :: chain integer :: status status = chain%status end function sf_chain_instance_get_status @ %def sf_chain_instance_get_status @ <>= procedure :: get_matrix_elements => sf_chain_instance_get_matrix_elements <>= module subroutine sf_chain_instance_get_matrix_elements (chain, i, ff) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: i real(default), intent(out), dimension(:), allocatable :: ff end subroutine sf_chain_instance_get_matrix_elements <>= module subroutine sf_chain_instance_get_matrix_elements (chain, i, ff) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: i real(default), intent(out), dimension(:), allocatable :: ff associate (sf => chain%sf(i)) ff = real (sf%int%get_matrix_element ()) end associate end subroutine sf_chain_instance_get_matrix_elements @ %def sf_chain_instance_get_matrix_elements @ <>= procedure :: get_beam_int_ptr => sf_chain_instance_get_beam_int_ptr <>= module function sf_chain_instance_get_beam_int_ptr (chain) result (int) type(interaction_t), pointer :: int class(sf_chain_instance_t), intent(in), target :: chain end function sf_chain_instance_get_beam_int_ptr <>= module function sf_chain_instance_get_beam_int_ptr (chain) result (int) type(interaction_t), pointer :: int class(sf_chain_instance_t), intent(in), target :: chain int => beam_get_int_ptr (chain%beam_t) end function sf_chain_instance_get_beam_int_ptr @ %def sf_chain_instance_get_beam_ptr @ <>= procedure :: get_n_sub => sf_chain_instance_get_n_sub <>= module function sf_chain_instance_get_n_sub (chain) result (n_sub) type(interaction_t), pointer :: int class(sf_chain_instance_t), intent(in), target :: chain integer :: n_sub end function sf_chain_instance_get_n_sub <>= module function sf_chain_instance_get_n_sub (chain) result (n_sub) type(interaction_t), pointer :: int class(sf_chain_instance_t), intent(in), target :: chain integer :: n_sub int => beam_get_int_ptr (chain%beam_t) n_sub = int%get_n_sub () end function sf_chain_instance_get_n_sub @ %def sf_chain_instance_get_n_sub @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_base_ut.f90]]>>= <> module sf_base_ut use unit_tests use sf_base_uti <> <> <> contains <> end module sf_base_ut @ %def sf_base_ut @ <<[[sf_base_uti.f90]]>>= <> module sf_base_uti <> <> use io_units use format_defs, only: FMT_19 use format_utils, only: write_separator use diagnostics use lorentz use pdg_arrays use flavors use colors use helicities use quantum_numbers use state_matrices, only: FM_IGNORE_HELICITY use interactions use particles use model_data use beams use sf_aux use sf_mappings use sf_base <> <> <> <> contains <> <> end module sf_base_uti @ %def sf_base_ut @ API: driver for the unit tests below. <>= public :: sf_base_test <>= subroutine sf_base_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_base_test @ %def sf_base_test @ \subsection{Test implementation: structure function} This is a template for the actual structure-function implementation which will be defined in separate modules. \subsubsection{Configuration data} The test structure function uses the [[Test]] model. It describes a scalar within an arbitrary initial particle, which is given in the initialization. The radiated particle is also a scalar, the same one, but we set its mass artificially to zero. <>= public :: sf_test_data_t <>= type, extends (sf_data_t) :: sf_test_data_t class(model_data_t), pointer :: model => null () integer :: mode = 0 type(flavor_t) :: flv_in type(flavor_t) :: flv_out type(flavor_t) :: flv_rad real(default) :: m = 0 logical :: collinear = .true. real(default), dimension(:), allocatable :: qbounds contains <> end type sf_test_data_t @ %def sf_test_data_t @ Output. <>= procedure :: write => sf_test_data_write <>= subroutine sf_test_data_write (data, unit, verbose) class(sf_test_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "SF test data:" write (u, "(3x,A,A)") "model = ", char (data%model%get_name ()) write (u, "(3x,A)", advance="no") "incoming = " call data%flv_in%write (u); write (u, *) write (u, "(3x,A)", advance="no") "outgoing = " call data%flv_out%write (u); write (u, *) write (u, "(3x,A)", advance="no") "radiated = " call data%flv_rad%write (u); write (u, *) write (u, "(3x,A," // FMT_19 // ")") "mass = ", data%m write (u, "(3x,A,L1)") "collinear = ", data%collinear if (.not. data%collinear .and. allocated (data%qbounds)) then write (u, "(3x,A," // FMT_19 // ")") "qmin = ", data%qbounds(1) write (u, "(3x,A," // FMT_19 // ")") "qmax = ", data%qbounds(2) end if end subroutine sf_test_data_write @ %def sf_test_data_write @ Initialization. <>= procedure :: init => sf_test_data_init <>= subroutine sf_test_data_init (data, model, pdg_in, collinear, qbounds, mode) class(sf_test_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in logical, intent(in), optional :: collinear real(default), dimension(2), intent(in), optional :: qbounds integer, intent(in), optional :: mode data%model => model if (present (mode)) data%mode = mode if (pdg_in%get (1) /= 25) then call msg_fatal ("Test spectrum function: input flavor must be 's'") end if call data%flv_in%init (25, model) data%m = data%flv_in%get_mass () if (present (collinear)) data%collinear = collinear call data%flv_out%init (25, model) call data%flv_rad%init (25, model) if (present (qbounds)) then allocate (data%qbounds (2)) data%qbounds = qbounds end if end subroutine sf_test_data_init @ %def sf_test_data_init @ Return the number of parameters: 1 if only consider collinear splitting, 3 otherwise. <>= procedure :: get_n_par => sf_test_data_get_n_par <>= function sf_test_data_get_n_par (data) result (n) class(sf_test_data_t), intent(in) :: data integer :: n if (data%collinear) then n = 1 else n = 3 end if end function sf_test_data_get_n_par @ %def sf_test_data_get_n_par @ Return the outgoing particle PDG code: 25 <>= procedure :: get_pdg_out => sf_test_data_get_pdg_out <>= subroutine sf_test_data_get_pdg_out (data, pdg_out) class(sf_test_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = 25 end subroutine sf_test_data_get_pdg_out @ %def sf_test_data_get_pdg_out @ Allocate the matching interaction. <>= procedure :: allocate_sf_int => sf_test_data_allocate_sf_int <>= subroutine sf_test_data_allocate_sf_int (data, sf_int) class(sf_test_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int if (allocated (sf_int)) deallocate (sf_int) allocate (sf_test_t :: sf_int) end subroutine sf_test_data_allocate_sf_int @ %def sf_test_data_allocate_sf_int @ \subsubsection{Interaction} <>= type, extends (sf_int_t) :: sf_test_t type(sf_test_data_t), pointer :: data => null () real(default) :: x = 0 contains <> end type sf_test_t @ %def sf_test_t @ Type string: constant <>= procedure :: type_string => sf_test_type_string <>= function sf_test_type_string (object) result (string) class(sf_test_t), intent(in) :: object type(string_t) :: string string = "Test" end function sf_test_type_string @ %def sf_test_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => sf_test_write <>= subroutine sf_test_write (object, unit, testflag) class(sf_test_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "SF test data: [undefined]" end if end subroutine sf_test_write @ %def sf_test_write @ Initialize. We know that [[data]] will be of concrete type [[sf_test_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass, but keep the radiated mass zero. Optionally, we can provide minimum and maximum values for the momentum transfer. <>= procedure :: init => sf_test_init <>= subroutine sf_test_init (sf_int, data) class(sf_test_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask type(helicity_t) :: hel0 type(color_t) :: col0 type(quantum_numbers_t), dimension(3) :: qn mask = quantum_numbers_mask (.false., .false., .false.) select type (data) type is (sf_test_data_t) if (allocated (data%qbounds)) then call sf_int%base_init (mask, & [data%m**2], [0._default], [data%m**2], & [data%qbounds(1)], [data%qbounds(2)]) else call sf_int%base_init (mask, & [data%m**2], [0._default], [data%m**2]) end if sf_int%data => data call hel0%init (0) call col0%init () call qn(1)%init (data%flv_in, col0, hel0) call qn(2)%init (data%flv_rad, col0, hel0) call qn(3)%init (data%flv_out, col0, hel0) call sf_int%add_state (qn) call sf_int%freeze () call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) end select sf_int%status = SF_INITIAL end subroutine sf_test_init @ %def sf_test_init @ Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, we are asked to provide an efficient mapping. For the test case, we set $x=r^2$ and consequently $f(r)=2r$. <>= procedure :: complete_kinematics => sf_test_complete_kinematics <>= subroutine sf_test_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(sf_test_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then x(1) = r(1)**2 f = 2 * r(1) else x(1) = r(1) f = 1 end if xb(1) = 1 - x(1) if (size (x) == 3) then x(2:3) = r(2:3) xb(2:3) = rb(2:3) end if call sf_int%split_momentum (x, xb) sf_int%x = x(1) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end subroutine sf_test_complete_kinematics @ %def sf_test_complete_kinematics @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => sf_test_inverse_kinematics <>= subroutine sf_test_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(sf_test_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then r(1) = sqrt (x(1)) f = 2 * r(1) else r(1) = x(1) f = 1 end if if (size (x) == 3) r(2:3) = x(2:3) rb = 1 - r sf_int%x = x(1) if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine sf_test_inverse_kinematics @ %def sf_test_inverse_kinematics @ Apply the structure function. The matrix element becomes unity and the application always succeeds. If the [[mode]] indicator is one, the matrix element is equal to the parameter~$x$. <>= procedure :: apply => sf_test_apply <>= subroutine sf_test_apply (sf_int, scale, negative_sf, rescale, i_sub) class(sf_test_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub select case (sf_int%data%mode) case (0) call sf_int%set_matrix_element & (cmplx (1._default, kind=default)) case (1) call sf_int%set_matrix_element & (cmplx (sf_int%x, kind=default)) end select sf_int%status = SF_EVALUATED end subroutine sf_test_apply @ %def sf_test_apply @ \subsection{Test implementation: pair spectrum} Another template, this time for a incoming particle pair, splitting into two radiated and two outgoing particles. \subsubsection{Configuration data} For simplicity, the spectrum contains two mirror images of the previous structure-function configuration: the incoming and all outgoing particles are test scalars. We have two versions, one with radiated particles, one without. <>= type, extends (sf_data_t) :: sf_test_spectrum_data_t class(model_data_t), pointer :: model => null () type(flavor_t) :: flv_in type(flavor_t) :: flv_out type(flavor_t) :: flv_rad logical :: with_radiation = .true. real(default) :: m = 0 contains <> end type sf_test_spectrum_data_t @ %def sf_test_spectrum_data_t @ Output. <>= procedure :: write => sf_test_spectrum_data_write <>= subroutine sf_test_spectrum_data_write (data, unit, verbose) class(sf_test_spectrum_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "SF test spectrum data:" write (u, "(3x,A,A)") "model = ", char (data%model%get_name ()) write (u, "(3x,A)", advance="no") "incoming = " call data%flv_in%write (u); write (u, *) write (u, "(3x,A)", advance="no") "outgoing = " call data%flv_out%write (u); write (u, *) write (u, "(3x,A)", advance="no") "radiated = " call data%flv_rad%write (u); write (u, *) write (u, "(3x,A," // FMT_19 // ")") "mass = ", data%m end subroutine sf_test_spectrum_data_write @ %def sf_test_spectrum_data_write @ Initialization. <>= procedure :: init => sf_test_spectrum_data_init <>= subroutine sf_test_spectrum_data_init (data, model, pdg_in, with_radiation) class(sf_test_spectrum_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in logical, intent(in) :: with_radiation data%model => model data%with_radiation = with_radiation if (pdg_in%get (1) /= 25) then call msg_fatal ("Test structure function: input flavor must be 's'") end if call data%flv_in%init (25, model) data%m = data%flv_in%get_mass () call data%flv_out%init (25, model) if (with_radiation) then call data%flv_rad%init (25, model) end if end subroutine sf_test_spectrum_data_init @ %def sf_test_spectrum_data_init @ Return the number of parameters: 2, since we have only collinear splitting here. <>= procedure :: get_n_par => sf_test_spectrum_data_get_n_par <>= function sf_test_spectrum_data_get_n_par (data) result (n) class(sf_test_spectrum_data_t), intent(in) :: data integer :: n n = 2 end function sf_test_spectrum_data_get_n_par @ %def sf_test_spectrum_data_get_n_par @ Return the outgoing particle PDG codes: 25 <>= procedure :: get_pdg_out => sf_test_spectrum_data_get_pdg_out <>= subroutine sf_test_spectrum_data_get_pdg_out (data, pdg_out) class(sf_test_spectrum_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = 25 pdg_out(2) = 25 end subroutine sf_test_spectrum_data_get_pdg_out @ %def sf_test_spectrum_data_get_pdg_out @ Allocate the matching interaction. <>= procedure :: allocate_sf_int => & sf_test_spectrum_data_allocate_sf_int <>= subroutine sf_test_spectrum_data_allocate_sf_int (data, sf_int) class(sf_test_spectrum_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (sf_test_spectrum_t :: sf_int) end subroutine sf_test_spectrum_data_allocate_sf_int @ %def sf_test_spectrum_data_allocate_sf_int @ \subsubsection{Interaction} <>= type, extends (sf_int_t) :: sf_test_spectrum_t type(sf_test_spectrum_data_t), pointer :: data => null () contains <> end type sf_test_spectrum_t @ %def sf_test_spectrum_t <>= procedure :: type_string => sf_test_spectrum_type_string <>= function sf_test_spectrum_type_string (object) result (string) class(sf_test_spectrum_t), intent(in) :: object type(string_t) :: string string = "Test Spectrum" end function sf_test_spectrum_type_string @ %def sf_test_spectrum_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => sf_test_spectrum_write <>= subroutine sf_test_spectrum_write (object, unit, testflag) class(sf_test_spectrum_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "SF test spectrum data: [undefined]" end if end subroutine sf_test_spectrum_write @ %def sf_test_spectrum_write @ Initialize. We know that [[data]] will be of concrete type [[sf_test_spectrum_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass, but keep the radiated mass zero. Optionally, we can provide minimum and maximum values for the momentum transfer. <>= procedure :: init => sf_test_spectrum_init <>= subroutine sf_test_spectrum_init (sf_int, data) class(sf_test_spectrum_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(6) :: mask type(helicity_t) :: hel0 type(color_t) :: col0 type(quantum_numbers_t), dimension(6) :: qn mask = quantum_numbers_mask (.false., .false., .false.) select type (data) type is (sf_test_spectrum_data_t) if (data%with_radiation) then call sf_int%base_init (mask(1:6), & [data%m**2, data%m**2], & [0._default, 0._default], & [data%m**2, data%m**2]) sf_int%data => data call hel0%init (0) call col0%init () call qn(1)%init (data%flv_in, col0, hel0) call qn(2)%init (data%flv_in, col0, hel0) call qn(3)%init (data%flv_rad, col0, hel0) call qn(4)%init (data%flv_rad, col0, hel0) call qn(5)%init (data%flv_out, col0, hel0) call qn(6)%init (data%flv_out, col0, hel0) call sf_int%add_state (qn(1:6)) call sf_int%set_incoming ([1,2]) call sf_int%set_radiated ([3,4]) call sf_int%set_outgoing ([5,6]) else call sf_int%base_init (mask(1:4), & [data%m**2, data%m**2], & [real(default) :: ], & [data%m**2, data%m**2]) sf_int%data => data call hel0%init (0) call col0%init () call qn(1)%init (data%flv_in, col0, hel0) call qn(2)%init (data%flv_in, col0, hel0) call qn(3)%init (data%flv_out, col0, hel0) call qn(4)%init (data%flv_out, col0, hel0) call sf_int%add_state (qn(1:4)) call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) end if call sf_int%freeze () end select sf_int%status = SF_INITIAL end subroutine sf_test_spectrum_init @ %def sf_test_spectrum_init @ Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, we are asked to provide an efficient mapping. For the test case, we set $x=r^2$ (as above) for both $x$ parameters and consequently $f(r)=4r_1r_2$. <>= procedure :: complete_kinematics => sf_test_spectrum_complete_kinematics <>= subroutine sf_test_spectrum_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(sf_test_spectrum_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map real(default), dimension(2) :: xb1 if (map) then x = r**2 f = 4 * r(1) * r(2) else x = r f = 1 end if xb = 1 - x if (sf_int%data%with_radiation) then call sf_int%split_momenta (x, xb) else call sf_int%reduce_momenta (x) end if select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end subroutine sf_test_spectrum_complete_kinematics @ %def sf_test_spectrum_complete_kinematics @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => sf_test_spectrum_inverse_kinematics <>= subroutine sf_test_spectrum_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(sf_test_spectrum_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default), dimension(2) :: xb1 logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then r = sqrt (x) f = 4 * r(1) * r(2) else r = x f = 1 end if rb = 1 - r if (set_mom) then if (sf_int%data%with_radiation) then call sf_int%split_momenta (x, xb) else call sf_int%reduce_momenta (x) end if select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine sf_test_spectrum_inverse_kinematics @ %def sf_test_spectrum_inverse_kinematics @ Apply the structure function. The matrix element becomes unity and the application always succeeds. <>= procedure :: apply => sf_test_spectrum_apply <>= subroutine sf_test_spectrum_apply (sf_int, scale, negative_sf, rescale, i_sub) class(sf_test_spectrum_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub call sf_int%set_matrix_element & (cmplx (1._default, kind=default)) sf_int%status = SF_EVALUATED end subroutine sf_test_spectrum_apply @ %def sf_test_spectrum_apply @ \subsection{Test implementation: generator spectrum} A generator for two beams, no radiation (for simplicity). \subsubsection{Configuration data} For simplicity, the spectrum contains two mirror images of the previous structure-function configuration: the incoming and all outgoing particles are test scalars. We have two versions, one with radiated particles, one without. <>= type, extends (sf_data_t) :: sf_test_generator_data_t class(model_data_t), pointer :: model => null () type(flavor_t) :: flv_in type(flavor_t) :: flv_out type(flavor_t) :: flv_rad real(default) :: m = 0 contains <> end type sf_test_generator_data_t @ %def sf_test_generator_data_t @ Output. <>= procedure :: write => sf_test_generator_data_write <>= subroutine sf_test_generator_data_write (data, unit, verbose) class(sf_test_generator_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "SF test generator data:" write (u, "(3x,A,A)") "model = ", char (data%model%get_name ()) write (u, "(3x,A)", advance="no") "incoming = " call data%flv_in%write (u); write (u, *) write (u, "(3x,A)", advance="no") "outgoing = " call data%flv_out%write (u); write (u, *) write (u, "(3x,A," // FMT_19 // ")") "mass = ", data%m end subroutine sf_test_generator_data_write @ %def sf_test_generator_data_write @ Initialization. <>= procedure :: init => sf_test_generator_data_init <>= subroutine sf_test_generator_data_init (data, model, pdg_in) class(sf_test_generator_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in data%model => model if (pdg_in%get (1) /= 25) then call msg_fatal ("Test generator: input flavor must be 's'") end if call data%flv_in%init (25, model) data%m = data%flv_in%get_mass () call data%flv_out%init (25, model) end subroutine sf_test_generator_data_init @ %def sf_test_generator_data_init @ This structure function is a generator. <>= procedure :: is_generator => sf_test_generator_data_is_generator <>= function sf_test_generator_data_is_generator (data) result (flag) class(sf_test_generator_data_t), intent(in) :: data logical :: flag flag = .true. end function sf_test_generator_data_is_generator @ %def sf_test_generator_data_is_generator @ Return the number of parameters: 2, since we have only collinear splitting here. <>= procedure :: get_n_par => sf_test_generator_data_get_n_par <>= function sf_test_generator_data_get_n_par (data) result (n) class(sf_test_generator_data_t), intent(in) :: data integer :: n n = 2 end function sf_test_generator_data_get_n_par @ %def sf_test_generator_data_get_n_par @ Return the outgoing particle PDG codes: 25 <>= procedure :: get_pdg_out => sf_test_generator_data_get_pdg_out <>= subroutine sf_test_generator_data_get_pdg_out (data, pdg_out) class(sf_test_generator_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = 25 pdg_out(2) = 25 end subroutine sf_test_generator_data_get_pdg_out @ %def sf_test_generator_data_get_pdg_out @ Allocate the matching interaction. <>= procedure :: allocate_sf_int => & sf_test_generator_data_allocate_sf_int <>= subroutine sf_test_generator_data_allocate_sf_int (data, sf_int) class(sf_test_generator_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (sf_test_generator_t :: sf_int) end subroutine sf_test_generator_data_allocate_sf_int @ %def sf_test_generator_data_allocate_sf_int @ \subsubsection{Interaction} <>= type, extends (sf_int_t) :: sf_test_generator_t type(sf_test_generator_data_t), pointer :: data => null () contains <> end type sf_test_generator_t @ %def sf_test_generator_t <>= procedure :: type_string => sf_test_generator_type_string <>= function sf_test_generator_type_string (object) result (string) class(sf_test_generator_t), intent(in) :: object type(string_t) :: string string = "Test Generator" end function sf_test_generator_type_string @ %def sf_test_generator_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => sf_test_generator_write <>= subroutine sf_test_generator_write (object, unit, testflag) class(sf_test_generator_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "SF test generator data: [undefined]" end if end subroutine sf_test_generator_write @ %def sf_test_generator_write @ Initialize. We know that [[data]] will be of concrete type [[sf_test_generator_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass. No radiation. <>= procedure :: init => sf_test_generator_init <>= subroutine sf_test_generator_init (sf_int, data) class(sf_test_generator_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(4) :: mask type(helicity_t) :: hel0 type(color_t) :: col0 type(quantum_numbers_t), dimension(4) :: qn mask = quantum_numbers_mask (.false., .false., .false.) select type (data) type is (sf_test_generator_data_t) call sf_int%base_init (mask(1:4), & [data%m**2, data%m**2], & [real(default) :: ], & [data%m**2, data%m**2]) sf_int%data => data call hel0%init (0) call col0%init () call qn(1)%init (data%flv_in, col0, hel0) call qn(2)%init (data%flv_in, col0, hel0) call qn(3)%init (data%flv_out, col0, hel0) call qn(4)%init (data%flv_out, col0, hel0) call sf_int%add_state (qn(1:4)) call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) call sf_int%freeze () end select sf_int%status = SF_INITIAL end subroutine sf_test_generator_init @ %def sf_test_generator_init @ This structure function is a generator. <>= procedure :: is_generator => sf_test_generator_is_generator <>= function sf_test_generator_is_generator (sf_int) result (flag) class(sf_test_generator_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function sf_test_generator_is_generator @ %def sf_test_generator_is_generator @ Generate free parameters. This mock generator always produces the nubmers 0.8 and 0.5. <>= procedure :: generate_free => sf_test_generator_generate_free <>= subroutine sf_test_generator_generate_free (sf_int, r, rb, x_free) class(sf_test_generator_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free r = [0.8, 0.5] rb= 1 - r x_free = x_free * product (r) end subroutine sf_test_generator_generate_free @ %def sf_test_generator_generate_free @ Recover momentum fractions. Since the x values are free, we also set the [[x_free]] parameter. <>= procedure :: recover_x => sf_test_generator_recover_x <>= subroutine sf_test_generator_recover_x (sf_int, x, xb, x_free) class(sf_test_generator_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb) if (present (x_free)) x_free = x_free * product (x) end subroutine sf_test_generator_recover_x @ %def sf_test_generator_recover_x @ Set kinematics. Since this is a generator, just transfer input to output. <>= procedure :: complete_kinematics => sf_test_generator_complete_kinematics <>= subroutine sf_test_generator_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(sf_test_generator_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map x = r xb= rb f = 1 call sf_int%reduce_momenta (x) end subroutine sf_test_generator_complete_kinematics @ %def sf_test_generator_complete_kinematics @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => sf_test_generator_inverse_kinematics <>= subroutine sf_test_generator_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(sf_test_generator_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta r = x rb= xb f = 1 if (set_mom) call sf_int%reduce_momenta (x) end subroutine sf_test_generator_inverse_kinematics @ %def sf_test_generator_inverse_kinematics @ Apply the structure function. The matrix element becomes unity and the application always succeeds. <>= procedure :: apply => sf_test_generator_apply <>= subroutine sf_test_generator_apply (sf_int, scale, negative_sf, rescale, i_sub) class(sf_test_generator_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub call sf_int%set_matrix_element & (cmplx (1._default, kind=default)) sf_int%status = SF_EVALUATED end subroutine sf_test_generator_apply @ %def sf_test_generator_apply @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_base_1, "sf_base_1", & "structure function configuration", & u, results) <>= public :: sf_base_1 <>= subroutine sf_base_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_base_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") call model%init_test () pdg_in = 25 allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle code:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_1" end subroutine sf_base_1 @ %def sf_base_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the test structure function. <>= call test (sf_base_2, "sf_base_2", & "structure function instance", & u, results) <>= public :: sf_base_2 <>= subroutine sf_base_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () pdg_in = 25 call flv%init (25, model) call reset_interaction_counter () allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Set kinematics for x=1" write (u, "(A)") r = 1 rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5" write (u, "(A)") r = 0.5_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Set kinematics with mapping for r=0.8" write (u, "(A)") r = 0.8_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Compute inverse kinematics for x=0.64 and evaluate" write (u, "(A)") x = 0.64_default call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%apply (scale=0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_2" end subroutine sf_base_2 @ %def sf_base_2 @ \subsubsection{Collinear kinematics} Scan over the possibilities for mass assignment and on-shell projections, collinear case. <>= call test (sf_base_3, "sf_base_3", & "alternatives for collinear kinematics", & u, results) <>= public :: sf_base_3 <>= subroutine sf_base_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_3" write (u, "(A)") "* Purpose: check various kinematical setups" write (u, "(A)") "* for collinear structure-function splitting." write (u, "(A)") " (two masses equal, one zero)" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () pdg_in = 25 call flv%init (25, model) call reset_interaction_counter () allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%write (u) allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set radiated mass to zero" sf_int%mr2 = 0 sf_int%mo2 = sf_int%mi2 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping energy" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set outgoing mass to zero" sf_int%mr2 = sf_int%mi2 sf_int%mo2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping energy" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set incoming mass to zero" k = vector4_moving (E, E, 3) call sf_int%seed_kinematics ([k]) sf_int%mr2 = sf_int%mi2 sf_int%mo2 = sf_int%mi2 sf_int%mi2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping energy" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set all masses to zero" sf_int%mr2 = 0 sf_int%mo2 = 0 sf_int%mi2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping energy" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_3" end subroutine sf_base_3 @ %def sf_base_3 @ \subsubsection{Non-collinear kinematics} Scan over the possibilities for mass assignment and on-shell projections, non-collinear case. <>= call test (sf_base_4, "sf_base_4", & "alternatives for non-collinear kinematics", & u, results) <>= public :: sf_base_4 <>= subroutine sf_base_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_4" write (u, "(A)") "* Purpose: check various kinematical setups" write (u, "(A)") "* for free structure-function splitting." write (u, "(A)") " (two masses equal, one zero)" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () pdg_in = 25 call flv%init (25, model) call reset_interaction_counter () allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in, collinear=.false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%write (u) allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set radiated mass to zero" sf_int%mr2 = 0 sf_int%mo2 = sf_int%mi2 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set outgoing mass to zero" sf_int%mr2 = sf_int%mi2 sf_int%mo2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set incoming mass to zero" k = vector4_moving (E, E, 3) call sf_int%seed_kinematics ([k]) sf_int%mr2 = sf_int%mi2 sf_int%mo2 = sf_int%mi2 sf_int%mi2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set all masses to zero" sf_int%mr2 = 0 sf_int%mo2 = 0 sf_int%mi2 = 0 write (u, "(A)") write (u, "(A)") "* Re-Initialize structure-function object with Q bounds" call reset_interaction_counter () select type (data) type is (sf_test_data_t) call data%init (model, pdg_in, collinear=.false., & qbounds = [1._default, 100._default]) end select call sf_int%init (data) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_4" end subroutine sf_base_4 @ %def sf_base_4 @ \subsubsection{Pair spectrum} Construct and display a structure function object for a pair spectrum (a structure function involving two particles simultaneously). <>= call test (sf_base_5, "sf_base_5", & "pair spectrum with radiation", & u, results) <>= public :: sf_base_5 <>= subroutine sf_base_5 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t), dimension(2) :: k type(vector4_t), dimension(4) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_5" write (u, "(A)") "* Purpose: initialize and fill & &a pair spectrum object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () allocate (sf_test_spectrum_data_t :: data) select type (data) type is (sf_test_spectrum_data_t) call data%init (model, pdg_in, with_radiation=.true.) end select write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 write (u, "(A)") write (u, "(A)") "* Initialize spectrum object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momenta with sqrts=1000" E = 500 k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) k(2) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics (k) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.4,0.8" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.4_default, 0.8_default] rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Set kinematics with mapping for r=0.6,0.8" write (u, "(A)") r = [0.6_default, 0.8_default] rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call reset_interaction_counter () call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%seed_kinematics (k) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Compute inverse kinematics for x=0.36,0.64 & &and evaluate" write (u, "(A)") x = [0.36_default, 0.64_default] xb = 1 - x call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%apply (scale=0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_5" end subroutine sf_base_5 @ %def sf_base_5 @ \subsubsection{Pair spectrum without radiation} Construct and display a structure function object for a pair spectrum (a structure function involving two particles simultaneously). <>= call test (sf_base_6, "sf_base_6", & "pair spectrum without radiation", & u, results) <>= public :: sf_base_6 <>= subroutine sf_base_6 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t), dimension(2) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_6" write (u, "(A)") "* Purpose: initialize and fill & &a pair spectrum object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () allocate (sf_test_spectrum_data_t :: data) select type (data) type is (sf_test_spectrum_data_t) call data%init (model, pdg_in, with_radiation=.false.) end select write (u, "(A)") "* Initialize spectrum object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) write (u, "(A)") "* Initialize incoming momenta with sqrts=1000" E = 500 k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) k(2) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics (k) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.4,0.8" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.4_default, 0.8_default] rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call reset_interaction_counter () call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%seed_kinematics (k) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Compute inverse kinematics for x=0.4,0.8 & &and evaluate" write (u, "(A)") x = [0.4_default, 0.8_default] xb = 1 - x call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale=0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_6" end subroutine sf_base_6 @ %def sf_base_6 @ \subsubsection{Direct access to structure function} Probe a structure function directly. <>= call test (sf_base_7, "sf_base_7", & "direct access", & u, results) <>= public :: sf_base_7 <>= subroutine sf_base_7 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int real(default), dimension(:), allocatable :: value write (u, "(A)") "* Test output: sf_base_7" write (u, "(A)") "* Purpose: check direct access method" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select call data%allocate_sf_int (sf_int) call sf_int%init (data) write (u, "(A)") "* Probe structure function: states" write (u, "(A)") write (u, "(A,I0)") "n_states = ", sf_int%get_n_states () write (u, "(A,I0)") "n_in = ", sf_int%get_n_in () write (u, "(A,I0)") "n_rad = ", sf_int%get_n_rad () write (u, "(A,I0)") "n_out = ", sf_int%get_n_out () write (u, "(A)") write (u, "(A)", advance="no") "state(1) = " call quantum_numbers_write (sf_int%get_state (1), u) write (u, *) allocate (value (sf_int%get_n_states ())) call sf_int%compute_values (value, & E=[500._default], x=[0.5_default], xb=[0.5_default], scale=0._default) write (u, "(A)") write (u, "(A)", advance="no") "value (E=500, x=0.5) =" write (u, "(9(1x," // FMT_19 // "))") value call sf_int%compute_values (value, & x=[0.1_default], xb=[0.9_default], scale=0._default) write (u, "(A)") write (u, "(A)", advance="no") "value (E=500, x=0.1) =" write (u, "(9(1x," // FMT_19 // "))") value write (u, "(A)") write (u, "(A)") "* Initialize spectrum object" write (u, "(A)") deallocate (value) call sf_int%final () deallocate (sf_int) deallocate (data) allocate (sf_test_spectrum_data_t :: data) select type (data) type is (sf_test_spectrum_data_t) call data%init (model, pdg_in, with_radiation=.false.) end select call data%allocate_sf_int (sf_int) call sf_int%init (data) write (u, "(A)") "* Probe spectrum: states" write (u, "(A)") write (u, "(A,I0)") "n_states = ", sf_int%get_n_states () write (u, "(A,I0)") "n_in = ", sf_int%get_n_in () write (u, "(A,I0)") "n_rad = ", sf_int%get_n_rad () write (u, "(A,I0)") "n_out = ", sf_int%get_n_out () write (u, "(A)") write (u, "(A)", advance="no") "state(1) = " call quantum_numbers_write (sf_int%get_state (1), u) write (u, *) allocate (value (sf_int%get_n_states ())) call sf_int%compute_value (1, value(1), & E = [500._default, 500._default], & x = [0.5_default, 0.6_default], & xb= [0.5_default, 0.4_default], & scale = 0._default) write (u, "(A)") write (u, "(A)", advance="no") "value (E=500,500, x=0.5,0.6) =" write (u, "(9(1x," // FMT_19 // "))") value write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_7" end subroutine sf_base_7 @ %def sf_base_7 @ \subsubsection{Structure function chain configuration} <>= call test (sf_base_8, "sf_base_8", & "structure function chain configuration", & u, results) <>= public :: sf_base_8 <>= subroutine sf_base_8 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun class(sf_data_t), allocatable, target :: data_spectrum type(sf_config_t), dimension(:), allocatable :: sf_config type(sf_chain_t) :: sf_chain write (u, "(A)") "* Test output: sf_base_8" write (u, "(A)") "* Purpose: set up a structure-function chain" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select allocate (sf_test_spectrum_data_t :: data_spectrum) select type (data_spectrum) type is (sf_test_spectrum_data_t) call data_spectrum%init (model, pdg_in, with_radiation=.true.) end select write (u, "(A)") "* Set up chain with beams only" write (u, "(A)") call sf_chain%init (beam_data) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Set up chain with structure function" write (u, "(A)") allocate (sf_config (1)) call sf_config(1)%init ([1], data_strfun) call sf_chain%init (beam_data, sf_config) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Set up chain with spectrum and structure function" write (u, "(A)") deallocate (sf_config) allocate (sf_config (2)) call sf_config(1)%init ([1,2], data_spectrum) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_8" end subroutine sf_base_8 @ %def sf_base_8 @ \subsubsection{Structure function instance configuration} We create a structure-function chain instance which implements a configured structure-function chain. We link the momentum entries in the interactions and compute kinematics. We do not actually connect the interactions and create evaluators. We skip this step and manually advance the status of the chain instead. <>= call test (sf_base_9, "sf_base_9", & "structure function chain instance", & u, results) <>= public :: sf_base_9 <>= subroutine sf_base_9 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun class(sf_data_t), allocatable, target :: data_spectrum type(sf_config_t), dimension(:), allocatable, target :: sf_config type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance type(sf_channel_t), dimension(2) :: sf_channel type(vector4_t), dimension(2) :: p integer :: j write (u, "(A)") "* Test output: sf_base_9" write (u, "(A)") "* Purpose: set up a structure-function chain & &and create an instance" write (u, "(A)") "* compute kinematics" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select allocate (sf_test_spectrum_data_t :: data_spectrum) select type (data_spectrum) type is (sf_test_spectrum_data_t) call data_spectrum%init (model, pdg_in, with_radiation=.true.) end select write (u, "(A)") "* Set up chain with beams only" write (u, "(A)") call sf_chain%init (beam_data) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%compute_kinematics (1, [real(default) ::]) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call sf_chain_instance%get_out_momenta (p) write (u, "(A)") write (u, "(A)") "* Outgoing momenta:" do j = 1, 2 write (u, "(A)") call vector4_write (p(j), u) end do call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Set up chain with structure function" write (u, "(A)") allocate (sf_config (1)) call sf_config(1)%init ([1], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(1)%init (1) call sf_channel(1)%activate_mapping ([1]) call sf_chain_instance%set_channel (1, sf_channel(1)) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%compute_kinematics (1, [0.8_default]) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call sf_chain_instance%get_out_momenta (p) write (u, "(A)") write (u, "(A)") "* Outgoing momenta:" do j = 1, 2 write (u, "(A)") call vector4_write (p(j), u) end do call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Set up chain with spectrum and structure function" write (u, "(A)") deallocate (sf_config) allocate (sf_config (2)) call sf_config(1)%init ([1,2], data_spectrum) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(2)%init (2) call sf_channel(2)%activate_mapping ([2]) call sf_chain_instance%set_channel (1, sf_channel(2)) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%compute_kinematics & (1, [0.5_default, 0.6_default, 0.8_default]) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call sf_chain_instance%get_out_momenta (p) write (u, "(A)") write (u, "(A)") "* Outgoing momenta:" do j = 1, 2 write (u, "(A)") call vector4_write (p(j), u) end do call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_9" end subroutine sf_base_9 @ %def sf_base_9 @ \subsubsection{Structure function chain mappings} Set up a structure function chain instance with a pair of single-particle structure functions. We test different global mappings for this setup. Again, we skip evaluators. <>= call test (sf_base_10, "sf_base_10", & "structure function chain mapping", & u, results) <>= public :: sf_base_10 <>= subroutine sf_base_10 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun type(sf_config_t), dimension(:), allocatable, target :: sf_config type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance type(sf_channel_t), dimension(2) :: sf_channel real(default), dimension(2) :: x_saved write (u, "(A)") "* Test output: sf_base_10" write (u, "(A)") "* Purpose: set up a structure-function chain" write (u, "(A)") "* and check mappings" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select write (u, "(A)") "* Set up chain with structure function pair & &and standard mapping" write (u, "(A)") allocate (sf_config (2)) call sf_config(1)%init ([1], data_strfun) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(1)%init (2) call sf_channel(1)%set_s_mapping ([1,2]) call sf_chain_instance%set_channel (1, sf_channel(1)) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%compute_kinematics (1, [0.8_default, 0.6_default]) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Invert the kinematics calculation" write (u, "(A)") x_saved = sf_chain_instance%x call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(2)%init (2) call sf_channel(2)%set_s_mapping ([1, 2]) call sf_chain_instance%set_channel (1, sf_channel(2)) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%inverse_kinematics (x_saved, 1 - x_saved) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_10" end subroutine sf_base_10 @ %def sf_base_10 @ \subsubsection{Structure function chain evaluation} Here, we test the complete workflow for structure-function chains. First, we create the template chain, then initialize an instance. We set up links, mask, and evaluators. Finally, we set kinematics and evaluate the matrix elements and their products. <>= call test (sf_base_11, "sf_base_11", & "structure function chain evaluation", & u, results) <>= public :: sf_base_11 <>= subroutine sf_base_11 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun class(sf_data_t), allocatable, target :: data_spectrum type(sf_config_t), dimension(:), allocatable, target :: sf_config type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance type(sf_channel_t), dimension(2) :: sf_channel type(particle_set_t) :: pset type(interaction_t), pointer :: int logical :: ok write (u, "(A)") "* Test output: sf_base_11" write (u, "(A)") "* Purpose: set up a structure-function chain" write (u, "(A)") "* create an instance and evaluate" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select allocate (sf_test_spectrum_data_t :: data_spectrum) select type (data_spectrum) type is (sf_test_spectrum_data_t) call data_spectrum%init (model, pdg_in, with_radiation=.true.) end select write (u, "(A)") "* Set up chain with beams only" write (u, "(A)") call sf_chain%init (beam_data) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () call sf_chain_instance%compute_kinematics (1, [real(default) ::]) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) int => sf_chain_instance%get_out_int_ptr () call pset%init (ok, int, int, FM_IGNORE_HELICITY, & [0._default, 0._default], .false., .true.) call sf_chain_instance%final () 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 chain:" write (u, "(A)") call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () int => sf_chain_instance%get_out_int_ptr () call pset%fill_interaction (int, 2, check_match=.false.) call sf_chain_instance%recover_kinematics (1) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call pset%final () call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") write (u, "(A)") write (u, "(A)") "* Set up chain with structure function" write (u, "(A)") allocate (sf_config (1)) call sf_config(1)%init ([1], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(1)%init (1) call sf_channel(1)%activate_mapping ([1]) call sf_chain_instance%set_channel (1, sf_channel(1)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () call sf_chain_instance%compute_kinematics (1, [0.8_default]) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) int => sf_chain_instance%get_out_int_ptr () call pset%init (ok, int, int, FM_IGNORE_HELICITY, & [0._default, 0._default], .false., .true.) call sf_chain_instance%final () 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 chain:" write (u, "(A)") call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(1)%init (1) call sf_channel(1)%activate_mapping ([1]) call sf_chain_instance%set_channel (1, sf_channel(1)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () int => sf_chain_instance%get_out_int_ptr () call pset%fill_interaction (int, 2, check_match=.false.) call sf_chain_instance%recover_kinematics (1) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call pset%final () call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") write (u, "(A)") write (u, "(A)") "* Set up chain with spectrum and structure function" write (u, "(A)") deallocate (sf_config) allocate (sf_config (2)) call sf_config(1)%init ([1,2], data_spectrum) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(2)%init (2) call sf_channel(2)%activate_mapping ([2]) call sf_chain_instance%set_channel (1, sf_channel(2)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () call sf_chain_instance%compute_kinematics & (1, [0.5_default, 0.6_default, 0.8_default]) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) int => sf_chain_instance%get_out_int_ptr () call pset%init (ok, int, int, FM_IGNORE_HELICITY, & [0._default, 0._default], .false., .true.) call sf_chain_instance%final () 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 chain:" write (u, "(A)") call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(2)%init (2) call sf_channel(2)%activate_mapping ([2]) call sf_chain_instance%set_channel (1, sf_channel(2)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () int => sf_chain_instance%get_out_int_ptr () call pset%fill_interaction (int, 2, check_match=.false.) call sf_chain_instance%recover_kinematics (1) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call pset%final () call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_11" end subroutine sf_base_11 @ %def sf_base_11 @ \subsubsection{Multichannel case} We set up a structure-function chain as before, but with three different parameterizations. The first instance is without mappings, the second one with single-particle mappings, and the third one with two-particle mappings. <>= call test (sf_base_12, "sf_base_12", & "multi-channel structure function chain", & u, results) <>= public :: sf_base_12 <>= subroutine sf_base_12 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data type(sf_config_t), dimension(:), allocatable, target :: sf_config type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance real(default), dimension(2) :: x_saved real(default), dimension(2,3) :: p_saved type(sf_channel_t), dimension(:), allocatable :: sf_channel write (u, "(A)") "* Test output: sf_base_12" write (u, "(A)") "* Purpose: set up and evaluate a multi-channel & &structure-function chain" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Set up chain with structure function pair & &and three different mappings" write (u, "(A)") allocate (sf_config (2)) call sf_config(1)%init ([1], data) call sf_config(2)%init ([2], data) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 3) call allocate_sf_channels (sf_channel, n_channel = 3, n_strfun = 2) ! channel 1: no mapping call sf_chain_instance%set_channel (1, sf_channel(1)) ! channel 2: single-particle mappings call sf_channel(2)%activate_mapping ([1,2]) ! call sf_chain_instance%activate_mapping (2, [1,2]) call sf_chain_instance%set_channel (2, sf_channel(2)) ! channel 3: two-particle mapping call sf_channel(3)%set_s_mapping ([1,2]) ! call sf_chain_instance%set_s_mapping (3, [1, 2]) call sf_chain_instance%set_channel (3, sf_channel(3)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () write (u, "(A)") "* Compute kinematics in channel 1 and evaluate" write (u, "(A)") call sf_chain_instance%compute_kinematics (1, [0.8_default, 0.6_default]) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Invert the kinematics calculation" write (u, "(A)") x_saved = sf_chain_instance%x call sf_chain_instance%inverse_kinematics (x_saved, 1 - x_saved) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Compute kinematics in channel 2 and evaluate" write (u, "(A)") p_saved = sf_chain_instance%p call sf_chain_instance%compute_kinematics (2, p_saved(:,2)) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Compute kinematics in channel 3 and evaluate" write (u, "(A)") call sf_chain_instance%compute_kinematics (3, p_saved(:,3)) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_chain_instance%final () call sf_chain%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_12" end subroutine sf_base_12 @ %def sf_base_12 @ \subsubsection{Generated spectrum} Construct and evaluate a structure function object for a pair spectrum which is evaluated as a beam-event generator. <>= call test (sf_base_13, "sf_base_13", & "pair spectrum generator", & u, results) <>= public :: sf_base_13 <>= subroutine sf_base_13 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t), dimension(2) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, x_free write (u, "(A)") "* Test output: sf_base_13" write (u, "(A)") "* Purpose: initialize and fill & &a pair generator object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () allocate (sf_test_generator_data_t :: data) select type (data) type is (sf_test_generator_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize generator object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) write (u, "(A)") "* Generate free r values" write (u, "(A)") x_free = 1 call sf_int%generate_free (r, rb, x_free) write (u, "(A)") "* Initialize incoming momenta with sqrts=1000" E = 500 k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) k(2) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics (k) write (u, "(A)") write (u, "(A)") "* Complete kinematics" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call reset_interaction_counter () call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%seed_kinematics (k) call sf_int%set_momenta (q, outgoing=.true.) x_free = 1 call sf_int%recover_x (x, xb, x_free) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Compute inverse kinematics & &and evaluate" write (u, "(A)") call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale=0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_13" end subroutine sf_base_13 @ %def sf_base_13 @ \subsubsection{Structure function chain evaluation} Here, we test the complete workflow for a structure-function chain with generator. First, we create the template chain, then initialize an instance. We set up links, mask, and evaluators. Finally, we set kinematics and evaluate the matrix elements and their products. <>= call test (sf_base_14, "sf_base_14", & "structure function generator evaluation", & u, results) <>= public :: sf_base_14 <>= subroutine sf_base_14 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun class(sf_data_t), allocatable, target :: data_generator type(sf_config_t), dimension(:), allocatable, target :: sf_config real(default), dimension(:), allocatable :: p_in type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance write (u, "(A)") "* Test output: sf_base_14" write (u, "(A)") "* Purpose: set up a structure-function chain" write (u, "(A)") "* create an instance and evaluate" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select allocate (sf_test_generator_data_t :: data_generator) select type (data_generator) type is (sf_test_generator_data_t) call data_generator%init (model, pdg_in) end select write (u, "(A)") "* Set up chain with generator and structure function" write (u, "(A)") allocate (sf_config (2)) call sf_config(1)%init ([1,2], data_generator) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () write (u, "(A)") "* Inject integration parameter" write (u, "(A)") allocate (p_in (sf_chain%get_n_bound ()), source = 0.9_default) write (u, "(A,9(1x,F10.7))") "p_in =", p_in write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_chain_instance%compute_kinematics (1, p_in) call sf_chain_instance%evaluate (scale=0._default) call sf_chain_instance%write (u) write (u, "(A)") write (u, "(A)") "* Extract integration parameter" write (u, "(A)") call sf_chain_instance%get_mcpar (1, p_in) write (u, "(A,9(1x,F10.7))") "p_in =", p_in call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_14" end subroutine sf_base_14 @ %def sf_base_14 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Photon radiation: ISR} <<[[sf_isr.f90]]>>= <> module sf_isr <> <> use pdg_arrays use model_data use flavors use sf_aux use sf_mappings use sf_base use electron_pdfs <> <> <> <> interface <> end interface contains <> end module sf_isr @ %def sf_isr @ <<[[sf_isr_sub.f90]]>>= <> submodule (sf_isr) sf_isr_s use io_units use constants, only: pi use format_defs, only: FMT_15, FMT_19 use numeric_utils use diagnostics use physics_defs, only: PHOTON use sm_physics, only: Li2 use lorentz use colors use quantum_numbers use polarizations implicit none contains <> end submodule sf_isr_s @ %def sf_isr_s @ \subsection{Physics} The ISR structure function is in the most crude approximation (LLA without $\alpha$ corrections, i.e. $\epsilon^0$) \begin{equation} f_0(x) = \epsilon (1-x)^{-1+\epsilon} \qquad\text{with}\qquad \epsilon = \frac{\alpha}{\pi}q_e^2\ln\frac{s}{m^2}, \end{equation} where $m$ is the mass of the incoming (and outgoing) particle, which is initially assumed on-shell. In $f_0(x)$, there is an integrable singularity at $x=1$ which does not spoil the integration, but would lead to an unbounded $f_{\rm max}$. Therefore, we map this singularity like \begin{equation}\label{ISR-mapping} x = 1 - (1-x')^{1/\epsilon} \end{equation} such that \begin{equation} \int dx\,f_0(x) = \int dx' \end{equation} For the detailed form of the QED ISR structure function cf. Chap.~\ref{chap:qed_pdf}. \subsection{Implementation} In the concrete implementation, the zeroth order mapping (\ref{ISR-mapping}) is implemented, and the Jacobian is equal to $f_i(x)/f_0(x)$. This can be written as \begin{align} \frac{f_0(x)}{f_0(x)} &= 1 \\ \frac{f_1(x)}{f_0(x)} &= 1 + \frac34\epsilon - \frac{1-x^2}{2(1-x')} \\ \begin{split}\label{ISR-f2} \frac{f_2(x)}{f_0(x)} &= 1 + \frac34\epsilon + \frac{27 - 8\pi^2}{96}\epsilon^2 - \frac{1-x^2}{2(1-x')} \\ &\quad - \frac{(1+3x^2)\ln x + (1-x)\left(4(1+x)\ln(1-x) + 5 + x\right)}{8(1-x')}\epsilon \end{split} \end{align} %' For $x=1$ (i.e., numerically indistinguishable from $1$), this reduces to \begin{align} \frac{f_0(x)}{f_0(x)} &= 1 \\ \frac{f_1(x)}{f_0(x)} &= 1 + \frac34\epsilon \\ \frac{f_2(x)}{f_0(x)} &= 1 + \frac34\epsilon + \frac{27 - 8\pi^2}{96}\epsilon^2 \end{align} The last line in (\ref{ISR-f2}) is zero for \begin{equation} x_{\rm min} = 0.00714053329734592839549879772019 \end{equation} (Mathematica result), independent of $\epsilon$. For $x$ values less than this we ignore this correction because of the logarithmic singularity which should in principle be resummed. \subsection{The ISR data block} <>= public :: isr_data_t <>= type, extends (sf_data_t) :: isr_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(:), allocatable :: flv_in type(qed_pdf_t) :: pdf real(default) :: alpha = 0 real(default) :: q_max = 0 real(default) :: real_mass = 0 real(default) :: mass = 0 real(default) :: eps = 0 real(default) :: log = 0 logical :: recoil = .false. logical :: keep_energy = .true. integer :: order = 3 integer :: error = NONE contains <> end type isr_data_t @ %def isr_data_t @ Error codes <>= integer, parameter :: NONE = 0 integer, parameter :: ZERO_MASS = 1 integer, parameter :: Q_MAX_TOO_SMALL = 2 integer, parameter :: EPS_TOO_LARGE = 3 integer, parameter :: INVALID_ORDER = 4 integer, parameter :: CHARGE_MIX = 5 integer, parameter :: CHARGE_ZERO = 6 integer, parameter :: MASS_MIX = 7 @ Generate flavor-dependent ISR data: <>= procedure :: init => isr_data_init <>= module subroutine isr_data_init (data, model, pdg_in, alpha, q_max, & mass, order, recoil, keep_energy) class(isr_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in real(default), intent(in) :: alpha real(default), intent(in) :: q_max real(default), intent(in), optional :: mass integer, intent(in), optional :: order logical, intent(in), optional :: recoil logical, intent(in), optional :: keep_energy end subroutine isr_data_init <>= module subroutine isr_data_init (data, model, pdg_in, alpha, q_max, & mass, order, recoil, keep_energy) class(isr_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in real(default), intent(in) :: alpha real(default), intent(in) :: q_max real(default), intent(in), optional :: mass integer, intent(in), optional :: order logical, intent(in), optional :: recoil logical, intent(in), optional :: keep_energy integer :: i, n_flv real(default) :: charge data%model => model n_flv = pdg_in%get_length () allocate (data%flv_in (n_flv)) do i = 1, n_flv call data%flv_in(i)%init (pdg_in%get (i), model) end do data%alpha = alpha data%q_max = q_max if (present (order)) then call data%set_order (order) end if if (present (recoil)) then data%recoil = recoil end if if (present (keep_energy)) then data%keep_energy = keep_energy end if data%real_mass = data%flv_in(1)%get_mass () if (present (mass)) then if (mass > 0) then data%mass = mass else data%mass = data%real_mass if (any (data%flv_in%get_mass () /= data%mass)) then data%error = MASS_MIX; return end if end if else data%mass = data%real_mass if (any (data%flv_in%get_mass () /= data%mass)) then data%error = MASS_MIX; return end if end if if (vanishes (data%mass)) then data%error = ZERO_MASS; return else if (data%mass >= data%q_max) then data%error = Q_MAX_TOO_SMALL; return end if data%log = log (1 + (data%q_max / data%mass)**2) charge = data%flv_in(1)%get_charge () if (any (abs (data%flv_in%get_charge ()) /= abs (charge))) then data%error = CHARGE_MIX; return else if (charge == 0) then data%error = CHARGE_ZERO; return end if data%eps = data%alpha / pi * charge ** 2 & * (2 * log (data%q_max / data%mass) - 1) if (data%eps > 1) then data%error = EPS_TOO_LARGE; return end if - call data%pdf%init & - (data%mass, data%alpha, charge, data%q_max, data%order) + call data%pdf%init (data%mass, data%alpha, charge, data%q_max, data%order, & + 0, 1) end subroutine isr_data_init @ %def isr_data_init @ Explicitly set ISR order <>= procedure :: set_order => isr_data_set_order <>= elemental module subroutine isr_data_set_order (data, order) class(isr_data_t), intent(inout) :: data integer, intent(in) :: order end subroutine isr_data_set_order <>= elemental module subroutine isr_data_set_order (data, order) class(isr_data_t), intent(inout) :: data integer, intent(in) :: order if (order < 0 .or. order > 3) then data%error = INVALID_ORDER else data%order = order end if end subroutine isr_data_set_order @ %def isr_data_set_order @ Handle error conditions. Should always be done after initialization, unless we are sure everything is ok. <>= procedure :: check => isr_data_check <>= module subroutine isr_data_check (data) class(isr_data_t), intent(in) :: data end subroutine isr_data_check <>= module subroutine isr_data_check (data) class(isr_data_t), intent(in) :: data select case (data%error) case (ZERO_MASS) call msg_fatal ("ISR: Particle mass is zero") case (Q_MAX_TOO_SMALL) call msg_fatal ("ISR: Particle mass exceeds Qmax") case (EPS_TOO_LARGE) call msg_fatal ("ISR: Expansion parameter too large, " // & "perturbative expansion breaks down") case (INVALID_ORDER) call msg_error ("ISR: LLA order invalid (valid values are 0,1,2,3)") case (MASS_MIX) call msg_fatal ("ISR: Incoming particle masses must be uniform") case (CHARGE_MIX) call msg_fatal ("ISR: Incoming particle charges must be uniform") case (CHARGE_ZERO) call msg_fatal ("ISR: Incoming particle must be charged") end select end subroutine isr_data_check @ %def isr_data_check @ Output <>= procedure :: write => isr_data_write <>= module subroutine isr_data_write (data, unit, verbose) class(isr_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine isr_data_write <>= module subroutine isr_data_write (data, unit, verbose) class(isr_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "ISR data:" if (allocated (data%flv_in)) then write (u, "(3x,A)", advance="no") " flavor = " do i = 1, size (data%flv_in) if (i > 1) write (u, "(',',1x)", advance="no") call data%flv_in(i)%write (u) end do write (u, *) write (u, "(3x,A," // FMT_19 // ")") " alpha = ", data%alpha write (u, "(3x,A," // FMT_19 // ")") " q_max = ", data%q_max write (u, "(3x,A," // FMT_19 // ")") " mass = ", data%mass write (u, "(3x,A," // FMT_19 // ")") " eps = ", data%eps write (u, "(3x,A," // FMT_19 // ")") " log = ", data%log write (u, "(3x,A,I2)") " order = ", data%order write (u, "(3x,A,L2)") " recoil = ", data%recoil write (u, "(3x,A,L2)") " keep en. = ", data%keep_energy else write (u, "(3x,A)") "[undefined]" end if end subroutine isr_data_write @ %def isr_data_write @ For ISR, there is the option to generate transverse momentum is generated. Hence, there can be up to three parameters, $x$, and two angles. <>= procedure :: get_n_par => isr_data_get_n_par <>= module function isr_data_get_n_par (data) result (n) class(isr_data_t), intent(in) :: data integer :: n end function isr_data_get_n_par <>= module function isr_data_get_n_par (data) result (n) class(isr_data_t), intent(in) :: data integer :: n if (data%recoil) then n = 3 else n = 1 end if end function isr_data_get_n_par @ %def isr_data_get_n_par @ Return the outgoing particles PDG codes. For ISR, these are identical to the incoming particles. <>= procedure :: get_pdg_out => isr_data_get_pdg_out <>= module subroutine isr_data_get_pdg_out (data, pdg_out) class(isr_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out end subroutine isr_data_get_pdg_out <>= module subroutine isr_data_get_pdg_out (data, pdg_out) class(isr_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = data%flv_in%get_pdg () end subroutine isr_data_get_pdg_out @ %def isr_data_get_pdg_out @ Return the [[eps]] value. We need it for an appropriate mapping of structure-function parameters. <>= procedure :: get_eps => isr_data_get_eps <>= module function isr_data_get_eps (data) result (eps) class(isr_data_t), intent(in) :: data real(default) :: eps end function isr_data_get_eps <>= module function isr_data_get_eps (data) result (eps) class(isr_data_t), intent(in) :: data real(default) :: eps eps = data%eps end function isr_data_get_eps @ %def isr_data_get_eps @ Allocate the interaction record. Gfortran 7/8/9 bug, has to remain in the module. <>= procedure :: allocate_sf_int => isr_data_allocate_sf_int <>= subroutine isr_data_allocate_sf_int (data, sf_int) class(isr_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (isr_t :: sf_int) end subroutine isr_data_allocate_sf_int @ %def isr_data_allocate_sf_int @ \subsection{The ISR object} The [[isr_t]] data type is a $1\to 2$ interaction, i.e., we allow for single-photon emission only (but use the multi-photon resummed radiator function). The particles are ordered as (incoming, photon, outgoing). There is no need to handle several flavors (and data blocks) in parallel, since ISR is always applied immediately after beam collision. (ISR for partons is accounted for by the PDFs themselves.) Polarization is carried through, i.e., we retain the polarization of the incoming particle and treat the emitted photon as unpolarized. Color is trivially carried through. This implies that particles 1 and 3 should be locked together. For ISR we don't need the q variable. <>= public :: isr_t <>= type, extends (sf_int_t) :: isr_t private type(isr_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: xb= 0 contains <> end type isr_t @ %def isr_t @ Type string: has to be here, but there is no string variable on which ISR depends. Hence, a dummy routine. <>= procedure :: type_string => isr_type_string <>= module function isr_type_string (object) result (string) class(isr_t), intent(in) :: object type(string_t) :: string end function isr_type_string <>= module function isr_type_string (object) result (string) class(isr_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "ISR: e+ e- ISR spectrum" else string = "ISR: [undefined]" end if end function isr_type_string @ %def isr_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => isr_write <>= module subroutine isr_write (object, unit, testflag) class(isr_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine isr_write <>= module subroutine isr_write (object, unit, testflag) class(isr_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_15 // ")") "x =", object%x write (u, "(3x,A," // FMT_15 // ")") "xb=", object%xb end if call object%base_write (u, testflag) else write (u, "(1x,A)") "ISR data: [undefined]" end if end subroutine isr_write @ %def isr_write @ Explicitly set ISR order (for unit test). <>= procedure :: set_order => isr_set_order <>= module subroutine isr_set_order (object, order) class(isr_t), intent(inout) :: object integer, intent(in) :: order end subroutine isr_set_order <>= module subroutine isr_set_order (object, order) class(isr_t), intent(inout) :: object integer, intent(in) :: order call object%data%set_order (order) call object%data%pdf%set_order (order) end subroutine isr_set_order @ %def isr_set_order @ \subsection{Kinematics} Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ were trivial. The ISR structure function allows for a straightforward mapping of the unit interval. So, to leading order, the structure function value is unity, but the $x$ value is transformed. Higher orders affect the function value. The structure function implementation applies the above mapping to the input (random) number [[r]] to generate the momentum fraction [[x]] and the function value [[f]]. For numerical stability reasons, we also output [[xb]], which is $\bar x=1-x$. For the ISR structure function, the mapping Jacobian cancels the structure function (to order zero). We apply the cancellation explicitly, therefore both the Jacobian [[f]] and the zeroth-order value (see the [[apply]] method) are unity if mapping is turned on. If mapping is turned off, the Jacobian [[f]] includes the value of the (zeroth-order) structure function, and strongly peaked. <>= procedure :: complete_kinematics => isr_complete_kinematics <>= module subroutine isr_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(isr_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map end subroutine isr_complete_kinematics <>= module subroutine isr_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(isr_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map real(default) :: eps eps = sf_int%data%eps if (map) then call map_power_1 (sf_int%xb, f, rb(1), eps) else sf_int%xb = rb(1) if (rb(1) > 0) then f = 1 else f = 0 end if end if sf_int%x = 1 - sf_int%xb x(1) = sf_int%x xb(1) = sf_int%xb if (size (x) == 3) then x(2:3) = r(2:3) xb(2:3) = rb(2:3) end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS) sf_int%x = 0 sf_int%xb= 0 f = 0 end select end subroutine isr_complete_kinematics @ %def isr_complete_kinematics @ Overriding the default method: we compute the [[x]] array from the momentum configuration. In the specific case of ISR, we also set the internally stored $x$ and $\bar x$ values, so they can be used in the following routine. <>= procedure :: recover_x => sf_isr_recover_x <>= module subroutine sf_isr_recover_x (sf_int, x, xb, x_free) class(isr_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free end subroutine sf_isr_recover_x <>= module subroutine sf_isr_recover_x (sf_int, x, xb, x_free) class(isr_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) sf_int%xb = xb(1) end subroutine sf_isr_recover_x @ %def sf_isr_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. For extracting $x$, we rely on the stored $\bar x$ value, since the $x$ value in the argument is likely imprecise. This means that either [[complete_kinematics]] or [[recover_x]] must be called first, for the current sampling point (but maybe another channel). <>= procedure :: inverse_kinematics => isr_inverse_kinematics <>= module subroutine isr_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(isr_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta end subroutine isr_inverse_kinematics <>= module subroutine isr_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(isr_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default) :: eps logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta eps = sf_int%data%eps if (map) then call map_power_inverse_1 (xb(1), f, rb(1), eps) else rb(1) = xb(1) if (rb(1) > 0) then f = 1 else f = 0 end if end if r(1) = 1 - rb(1) if (size(r) == 3) then r(2:3) = x(2:3) rb(2:3)= xb(2:3) end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS) r = 0 rb= 0 f = 0 end select end if end subroutine isr_inverse_kinematics @ %def isr_inverse_kinematics @ <>= procedure :: init => isr_init <>= module subroutine isr_init (sf_int, data) class(isr_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data end subroutine isr_init <>= module subroutine isr_init (sf_int, data) class(isr_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask integer, dimension(3) :: hel_lock type(polarization_t), target :: pol type(quantum_numbers_t), dimension(1) :: qn_fc type(flavor_t) :: flv_photon type(color_t) :: col_photon type(quantum_numbers_t) :: qn_hel, qn_photon, qn type(polarization_iterator_t) :: it_hel real(default) :: m2 integer :: i mask = quantum_numbers_mask (.false., .false., & mask_h = [.false., .true., .false.]) hel_lock = [3, 0, 1] select type (data) type is (isr_data_t) m2 = data%mass**2 call sf_int%base_init (mask, [m2], [0._default], [m2], & hel_lock = hel_lock) sf_int%data => data call flv_photon%init (PHOTON, data%model) call col_photon%init () call qn_photon%init (flv_photon, col_photon) call qn_photon%tag_radiated () do i = 1, size (data%flv_in) call pol%init_generic (data%flv_in(i)) call qn_fc(1)%init (& flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i), 1)) call it_hel%init (pol) do while (it_hel%is_valid ()) qn_hel = it_hel%get_quantum_numbers () qn = qn_hel .merge. qn_fc(1) call sf_int%add_state ([qn, qn_photon, qn]) call it_hel%advance () end do ! call pol%final () !!! Obsolete end do call sf_int%freeze () if (data%keep_energy) then sf_int%on_shell_mode = KEEP_ENERGY else sf_int%on_shell_mode = KEEP_MOMENTUM end if call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) sf_int%status = SF_INITIAL end select end subroutine isr_init @ %def isr_init @ \subsection{ISR application} For ISR, we could in principle compute kinematics and function value in a single step. In order to be able to reweight matrix elements including structure functions we split kinematics and structure function calculation. The structure function works on a single beam, assuming that the input momentum has been set. For the structure-function evaluation, we rely on the fact that the power mapping, which we apply in the kinematics method (if the [[map]] flag is set), has a Jacobian which is just the inverse lowest-order structure function. With mapping active, the two should cancel exactly. After splitting momenta, we set the outgoing momenta on-shell. We choose to conserve momentum, so energy conservation may be violated. <>= procedure :: apply => isr_apply <>= module subroutine isr_apply (sf_int, scale, negative_sf, rescale, i_sub) class(isr_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub end subroutine isr_apply <>= module subroutine isr_apply (sf_int, scale, negative_sf, rescale, i_sub) class(isr_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: f, finv, x, xb, eps, rb real(default) :: log_x, log_xb, x_2 associate (data => sf_int%data) eps = sf_int%data%eps x = sf_int%x xb = sf_int%xb call map_power_inverse_1 (xb, finv, rb, eps) if (finv > 0) then f = 1 / finv else f = 0 end if call data%pdf%evolve_qed_pdf (x, xb, rb, f) end associate call sf_int%set_matrix_element (cmplx (f, kind=default)) sf_int%status = SF_EVALUATED end subroutine isr_apply @ %def isr_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_isr_ut.f90]]>>= <> module sf_isr_ut use unit_tests use sf_isr_uti <> <> contains <> end module sf_isr_ut @ %def sf_isr_ut @ <<[[sf_isr_uti.f90]]>>= <> module sf_isr_uti <> <> use io_units use format_defs, only: FMT_12 use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use interactions, only: interaction_t use model_data use sf_aux, only: KEEP_ENERGY use sf_mappings use sf_base use sf_isr <> <> contains <> end module sf_isr_uti @ %def sf_isr_ut @ API: driver for the unit tests below. <>= public :: sf_isr_test <>= subroutine sf_isr_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_isr_test @ %def sf_isr_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_isr_1, "sf_isr_1", & "structure function configuration", & u, results) <>= public :: sf_isr_1 <>= subroutine sf_isr_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_isr_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_qed_test () pdg_in = ELECTRON allocate (isr_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 10._default, & 0.000511_default, order = 3, recoil = .false.) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_1" end subroutine sf_isr_1 @ %def sf_isr_1 @ \subsubsection{Structure function without mapping} Direct ISR evaluation. This is the use case for a double-beam structure function. The parameter pair is mapped in the calling program. <>= call test (sf_isr_2, "sf_isr_2", & "no ISR mapping", & u, results) <>= public :: sf_isr_2 <>= subroutine sf_isr_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, f_isr write (u, "(A)") "* Test output: sf_isr_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () pdg_in = ELECTRON call flv%init (ELECTRON, model) call reset_interaction_counter () allocate (isr_data_t :: data) select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 500._default, & 0.000511_default, order = 3, recoil = .false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.9, no ISR mapping, & &collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.9_default rb = 1 - r write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A)") write (u, "(A,9(1x," // FMT_12 // "))") "x =", x write (u, "(A,9(1x," // FMT_12 // "))") "xb=", xb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Invert kinematics" write (u, "(A)") call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate ISR structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Structure-function value, default order" write (u, "(A)") f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Re-evaluate structure function, leading order" write (u, "(A)") select type (sf_int) type is (isr_t) call sf_int%set_order (0) end select call sf_int%apply (scale = 100._default) f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_2" end subroutine sf_isr_2 @ %def sf_isr_2 @ \subsubsection{Structure function with mapping} Apply the optimal ISR mapping. This is the use case for a single-beam structure function. <>= call test (sf_isr_3, "sf_isr_3", & "ISR mapping", & u, results) <>= public :: sf_isr_3 <>= subroutine sf_isr_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, f_isr write (u, "(A)") "* Test output: sf_isr_3" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (isr_data_t :: data) select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 500._default, & 0.000511_default, order = 3, recoil = .false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.7, with ISR mapping, & &collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.7_default rb = 1 - r write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A)") write (u, "(A,9(1x," // FMT_12 // "))") "x =", x write (u, "(A,9(1x," // FMT_12 // "))") "xb=", xb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Invert kinematics" write (u, "(A)") call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate ISR structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Structure-function value, default order" write (u, "(A)") f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Re-evaluate structure function, leading order" write (u, "(A)") select type (sf_int) type is (isr_t) call sf_int%set_order (0) end select call sf_int%apply (scale = 100._default) f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_3" end subroutine sf_isr_3 @ %def sf_isr_3 @ \subsubsection{Non-collinear ISR splitting} Construct and display a structure function object based on the ISR structure function. We blank out numerical fluctuations for 32bit. <>= call test (sf_isr_4, "sf_isr_4", & "ISR non-collinear", & u, results) <>= public :: sf_isr_4 <>= subroutine sf_isr_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, f_isr character(len=80) :: buffer integer :: u_scratch, iostat write (u, "(A)") "* Test output: sf_isr_4" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () write (u, "(A)") write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") allocate (isr_data_t :: data) select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 500._default, & 0.000511_default, order = 3, recoil = .true.) end select call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.25, with ISR mapping, " write (u, "(A)") " non-coll., keeping energy" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.5_default, 0.5_default, 0.25_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%pacify_momenta (1e-10_default) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x and r from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A)") write (u, "(A)") "* Evaluate ISR structure function" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%pacify_momenta (1e-10_default) call sf_int%apply (scale = 10._default) u_scratch = free_unit () open (u_scratch, status="scratch", action = "readwrite") call sf_int%write (u_scratch, testflag = .true.) rewind (u_scratch) do read (u_scratch, "(A)", iostat=iostat) buffer if (iostat /= 0) exit if (buffer(1:25) == " P = 0.000000E+00 9.57") then buffer = replace (buffer, 26, "XXXX") end if if (buffer(1:25) == " P = 0.000000E+00 -9.57") then buffer = replace (buffer, 26, "XXXX") end if write (u, "(A)") buffer end do close (u_scratch) write (u, "(A)") write (u, "(A)") "* Structure-function value" write (u, "(A)") f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_4" end subroutine sf_isr_4 @ %def sf_isr_4 @ \subsubsection{Structure function pair with mapping} Apply the ISR mapping for a ISR pair. structure function. <>= call test (sf_isr_5, "sf_isr_5", & "ISR pair mapping", & u, results) <>= public :: sf_isr_5 <>= subroutine sf_isr_5 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_mapping_t), allocatable :: mapping class(sf_int_t), dimension(:), allocatable :: sf_int type(vector4_t), dimension(2) :: k real(default) :: E, f_map real(default), dimension(:), allocatable :: p, pb, r, rb, x, xb real(default), dimension(2) :: f, f_isr integer :: i write (u, "(A)") "* Test output: sf_isr_5" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (isr_data_t :: data) select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 500._default, & 0.000511_default, order = 3, recoil = .false.) end select allocate (sf_ip_mapping_t :: mapping) select type (mapping) type is (sf_ip_mapping_t) select type (data) type is (isr_data_t) call mapping%init (eps = data%get_eps ()) end select call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, "(A)") write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") allocate (isr_t :: sf_int (2)) do i = 1, 2 call sf_int(i)%init (data) call sf_int(i)%set_beam_index ([i]) end do write (u, "(A)") "* Initialize incoming momenta with E=500" write (u, "(A)") E = 500 k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) k(2) = vector4_moving (E, - sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) do i = 1, 2 call vector4_write (k(i), u) call sf_int(i)%seed_kinematics (k(i:i)) end do write (u, "(A)") write (u, "(A)") "* Set kinematics for p=[0.7,0.4], collinear" write (u, "(A)") allocate (p (2 * data%get_n_par ())) allocate (pb(size (p))) allocate (r (size (p))) allocate (rb(size (p))) allocate (x (size (p))) allocate (xb(size (p))) p = [0.7_default, 0.4_default] pb= 1 - p call mapping%compute (r, rb, f_map, p, pb) write (u, "(A,9(1x," // FMT_12 // "))") "p =", p write (u, "(A,9(1x," // FMT_12 // "))") "pb=", pb write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb write (u, "(A,9(1x," // FMT_12 // "))") "fm=", f_map do i = 1, 2 call sf_int(i)%complete_kinematics (x(i:i), xb(i:i), f(i), r(i:i), rb(i:i), & map=.false.) end do write (u, "(A)") write (u, "(A,9(1x," // FMT_12 // "))") "x =", x write (u, "(A,9(1x," // FMT_12 // "))") "xb=", xb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Invert kinematics" write (u, "(A)") do i = 1, 2 call sf_int(i)%inverse_kinematics (x(i:i), xb(i:i), f(i), r(i:i), rb(i:i), & map=.false.) end do call mapping%inverse (r, rb, f_map, p, pb) write (u, "(A,9(1x," // FMT_12 // "))") "p =", p write (u, "(A,9(1x," // FMT_12 // "))") "pb=", pb write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb write (u, "(A,9(1x," // FMT_12 // "))") "fm=", f_map write (u, "(A)") write (u, "(A)") "* Evaluate ISR structure function" call sf_int(1)%apply (scale = 100._default) call sf_int(2)%apply (scale = 100._default) write (u, "(A)") write (u, "(A)") "* Structure function #1" write (u, "(A)") call sf_int(1)%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Structure function #2" write (u, "(A)") call sf_int(2)%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Structure-function value, default order" write (u, "(A)") do i = 1, 2 f_isr(i) = sf_int(i)%get_matrix_element (1) end do write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", & product (f_isr) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", & product (f_isr * f) * f_map write (u, "(A)") write (u, "(A)") "* Cleanup" do i = 1, 2 call sf_int(i)%final () end do call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_5" end subroutine sf_isr_5 @ %def sf_isr_5 @ \clearpage %------------------------------------------------------------------------ \section{EPA} <<[[sf_epa.f90]]>>= <> module sf_epa <> <> use lorentz use pdg_arrays use model_data use flavors use quantum_numbers use state_matrices use polarizations use interactions use sf_aux use sf_base <> <> <> <> interface <> end interface contains <> end module sf_epa @ %def sf_epa @ <<[[sf_epa_sub.f90]]>>= <> submodule (sf_epa) sf_epa_s use io_units use constants, only: pi use format_defs, only: FMT_17, FMT_19 use numeric_utils use diagnostics use physics_defs, only: PHOTON use colors implicit none contains <> end submodule sf_epa_s @ %def sf_epa_s @ \subsection{Physics} The EPA structure function for a photon inside an (elementary) particle $p$ with energy $E$, mass $m$ and charge $q_p$ (e.g., electron) is given by ($\bar x \equiv 1-x$) There are several variants of the EPA, which are steered by the [[\$epa\_mode]] switch. The formula (6.17b) from the report by Budnev et al. is given by %% %\cite{Budnev:1974de} %% \bibitem{Budnev:1974de} %% V.~M.~Budnev, I.~F.~Ginzburg, G.~V.~Meledin and V.~G.~Serbo, %% %``The Two photon particle production mechanism. Physical problems. %% %Applications. Equivalent photon approximation,'' %% Phys.\ Rept.\ {\bf 15} (1974) 181. %% %%CITATION = PRPLC,15,181;%% \begin{multline} \label{EPA_617} f(x) = \frac{\alpha}{\pi}\,q_p^2\, \frac{1}{x}\, \biggl[\left(\bar x + \frac{x^2}{2}\right) \ln\frac{Q^2_{\rm max}}{Q^2_{\rm min}} \\ - \left(1 - \frac{x}{2}\right)^2 \ln\frac{x^2+\frac{Q^2_{\rm max}}{E^2}} {x^2+\frac{Q^2_{\rm min}}{E^2}} - x^2\frac{m^2}{Q^2_{\rm min}} \left(1 - \frac{Q^2_{\rm min}}{Q^2_{\rm max}}\right) \biggr]. \end{multline} If no explicit $Q$ bounds are provided, the kinematical bounds are \begin{align} -Q^2_{\rm max} &= t_0 = -2\bar x(E^2+p\bar p) + 2m^2 \approx -4\bar x E^2, \\ -Q^2_{\rm min} &= t_1 = -2\bar x(E^2-p\bar p) + 2m^2 \approx -\frac{x^2}{\bar x}m^2. \end{align} The second and third terms in (\ref{EPA_617}) are negative definite (and subleading). Noting that $\bar x + x^2/2$ is bounded between $1/2$ and $1$, we derive that $f(x)$ is always smaller than \begin{equation} \bar f(x) = \frac{\alpha}{\pi}\,q_p^2\,\frac{L - 2\ln x}{x} \qquad\text{where}\qquad L = \ln\frac{\min(4E_{\rm max}^2,Q^2_{\rm max})}{\max(m^2,Q_{\rm min}^2)}, \end{equation} where we allow for explicit $Q$ bounds that narrow the kinematical range. Therefore, we generate this distribution: \begin{equation}\label{EPA-subst} \int_{x_0}^{x_1} dx\,\bar f(x) = C(x_0,x_1)\int_0^1 dx' \end{equation} We set \begin{equation}\label{EPA-x(x')} \ln x = \frac12\left\{ L - \sqrt{L^2 - 4\left[ x'\ln x_1(L-\ln x_1) + \bar x'\ln x_0(L-\ln x_0) \right]} \right\} \end{equation} such that $x(0)=x_0$ and $x(1)=x_1$ and \begin{equation} \frac{dx}{dx'} = \left(\frac{\alpha}{\pi} q_p^2 \right)^{-1} x\frac{C(x_0,x_1)}{L - 2\ln x} \end{equation} with \begin{equation} C(x_0,x_1) = \frac{\alpha}{\pi} q_p^2\,\left[\ln x_1(L-\ln x_1) - \ln x_0(L-\ln x_0)\right] \end{equation} such that (\ref{EPA-subst}) is satisfied. Finally, we have \begin{equation} \int_{x_0}^{x_1} dx\,f(x) = C(x_0,x_1)\int_0^1 dx'\, \frac{f(x(x'))}{\bar f(x(x'))} \end{equation} where $x'$ is calculated from $x$ via (\ref{EPA-x(x')}). The structure of the mapping is most obvious from: \begin{equation} x'(x) = \frac{\log x ( L - \log x) - \log x_0 (L - \log x_0)} {\log x_1 ( L - \log x_1) - \log x_0 (L - \log x_0)} \; . \end{equation} Taking the Eq. (6.16e) from the Budnev et al. report, and integrating it over $q^2$ yields the modified result \begin{equation} \label{EPA_616e} f(x) = \frac{\alpha}{\pi}\,q_p^2\, \frac{1}{x}\, \biggl[\left(\bar x + \frac{x^2}{2}\right) \ln\frac{Q^2_{\rm max}}{Q^2_{\rm min}} - x^2\frac{m^2}{Q^2_{\rm min}} \left(1 - \frac{Q^2_{\rm min}}{Q^2_{\rm max}}\right) \biggr]. \end{equation} This is closer to many standard papers from LEP times, and to textbook formulae like e.g. in Peskin/Schroeder. For historical reasons, we keep Eq.~(\ref{EPA_617}) as the default in \whizard. \subsection{The EPA data block} The EPA parameters are: $\alpha$, $E_{\rm max}$, $m$, $Q_{\rm min}$, and $x_{\rm min}$. Instead of $m$ we can use the incoming particle PDG code as input; from this we can deduce the mass and charge. Internally we store in addition $C_{0/1} = \frac{\alpha}{\pi}q_e^2\ln x_{0/1} (L - \ln x_{0/1})$, the c.m. energy squared and the incoming particle mass. <>= public :: EPA_MODE_DEFAULT public :: EPA_MODE_BUDNEV_617 public :: EPA_MODE_BUDNEV_616E public :: EPA_MODE_LOG_POWER public :: EPA_MODE_LOG_SIMPLE public :: EPA_MODE_LOG <>= integer, parameter :: EPA_MODE_DEFAULT = 0 integer, parameter :: EPA_MODE_BUDNEV_617 = 0 integer, parameter :: EPA_MODE_BUDNEV_616E = 1 integer, parameter :: EPA_MODE_LOG_POWER = 2 integer, parameter :: EPA_MODE_LOG_SIMPLE = 3 integer, parameter :: EPA_MODE_LOG = 4 @ %def EPA_MODE_DEFAULT EPA_MODE_BUDNEV_617 EPA_MODE_BUDNEV_616E @ %def EPA_MODE_LOG_POWER EPA_MODE_LOG_SIMPLE EPA_MODE_LOG @ <>= public :: epa_data_t <>= type, extends(sf_data_t) :: epa_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(:), allocatable :: flv_in real(default) :: alpha real(default) :: x_min real(default) :: x_max real(default) :: q_min real(default) :: q_max real(default) :: E_max real(default) :: mass real(default) :: log real(default) :: a real(default) :: c0 real(default) :: c1 real(default) :: dc integer :: mode = EPA_MODE_DEFAULT integer :: error = NONE logical :: recoil = .false. logical :: keep_energy = .true. contains <> end type epa_data_t @ %def epa_data_t @ Error codes <>= integer, parameter :: NONE = 0 integer, parameter :: ZERO_QMIN = 1 integer, parameter :: Q_MAX_TOO_SMALL = 2 integer, parameter :: ZERO_XMIN = 3 integer, parameter :: MASS_MIX = 4 integer, parameter :: NO_EPA = 5 <>= procedure :: init => epa_data_init <>= module subroutine epa_data_init (data, model, mode, pdg_in, alpha, & x_min, q_min, q_max, mass, recoil, keep_energy) class(epa_data_t), intent(inout) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in integer, intent(in) :: mode real(default), intent(in) :: alpha, x_min, q_min, q_max real(default), intent(in), optional :: mass logical, intent(in), optional :: recoil logical, intent(in), optional :: keep_energy end subroutine epa_data_init <>= module subroutine epa_data_init (data, model, mode, pdg_in, alpha, & x_min, q_min, q_max, mass, recoil, keep_energy) class(epa_data_t), intent(inout) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in integer, intent(in) :: mode real(default), intent(in) :: alpha, x_min, q_min, q_max real(default), intent(in), optional :: mass logical, intent(in), optional :: recoil logical, intent(in), optional :: keep_energy integer :: n_flv, i data%model => model data%mode = mode n_flv = pdg_in%get_length () allocate (data%flv_in (n_flv)) do i = 1, n_flv call data%flv_in(i)%init (pdg_in%get (i), model) end do data%alpha = alpha data%E_max = q_max / 2 data%x_min = x_min data%x_max = 1 if (vanishes (data%x_min)) then data%error = ZERO_XMIN; return end if data%q_min = q_min data%q_max = q_max select case (char (data%model%get_name ())) case ("QCD","Test") data%error = NO_EPA; return end select if (present (recoil)) then data%recoil = recoil end if if (present (keep_energy)) then data%keep_energy = keep_energy end if if (present (mass)) then data%mass = mass else data%mass = data%flv_in(1)%get_mass () if (any (data%flv_in%get_mass () /= data%mass)) then data%error = MASS_MIX; return end if end if if (max (data%mass, data%q_min) == 0) then data%error = ZERO_QMIN; return else if (max (data%mass, data%q_min) >= data%E_max) then data%error = Q_MAX_TOO_SMALL; return end if data%log = log ((data%q_max / max (data%mass, data%q_min)) ** 2 ) data%a = data%alpha / pi data%c0 = log (data%x_min) * (data%log - log (data%x_min)) data%c1 = log (data%x_max) * (data%log - log (data%x_max)) data%dc = data%c1 - data%c0 end subroutine epa_data_init @ %def epa_data_init @ Handle error conditions. Should always be done after initialization, unless we are sure everything is ok. <>= procedure :: check => epa_data_check <>= module subroutine epa_data_check (data) class(epa_data_t), intent(in) :: data end subroutine epa_data_check <>= module subroutine epa_data_check (data) class(epa_data_t), intent(in) :: data select case (data%error) case (NO_EPA) call msg_fatal ("EPA structure function not available for model " & // char (data%model%get_name ()) // ".") case (ZERO_QMIN) call msg_fatal ("EPA: Particle mass is zero") case (Q_MAX_TOO_SMALL) call msg_fatal ("EPA: Particle mass exceeds Qmax") case (ZERO_XMIN) call msg_fatal ("EPA: x_min must be larger than zero") case (MASS_MIX) call msg_fatal ("EPA: incoming particle masses must be uniform") end select end subroutine epa_data_check @ %def epa_data_check @ Output <>= procedure :: write => epa_data_write <>= module subroutine epa_data_write (data, unit, verbose) class(epa_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine epa_data_write <>= module subroutine epa_data_write (data, unit, verbose) class(epa_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "EPA data:" if (allocated (data%flv_in)) then write (u, "(3x,A)", advance="no") " flavor = " do i = 1, size (data%flv_in) if (i > 1) write (u, "(',',1x)", advance="no") call data%flv_in(i)%write (u) end do write (u, *) write (u, "(3x,A," // FMT_19 // ")") " alpha = ", data%alpha write (u, "(3x,A," // FMT_19 // ")") " x_min = ", data%x_min write (u, "(3x,A," // FMT_19 // ")") " x_max = ", data%x_max write (u, "(3x,A," // FMT_19 // ")") " q_min = ", data%q_min write (u, "(3x,A," // FMT_19 // ")") " q_max = ", data%q_max write (u, "(3x,A," // FMT_19 // ")") " E_max = ", data%e_max write (u, "(3x,A," // FMT_19 // ")") " mass = ", data%mass write (u, "(3x,A," // FMT_19 // ")") " a = ", data%a write (u, "(3x,A," // FMT_19 // ")") " c0 = ", data%c0 write (u, "(3x,A," // FMT_19 // ")") " c1 = ", data%c1 write (u, "(3x,A," // FMT_19 // ")") " log = ", data%log write (u, "(3x,A,L2)") " recoil = ", data%recoil write (u, "(3x,A,L2)") " keep en. = ", data%keep_energy else write (u, "(3x,A)") "[undefined]" end if end subroutine epa_data_write @ %def epa_data_write @ The number of kinematic parameters. <>= procedure :: get_n_par => epa_data_get_n_par <>= module function epa_data_get_n_par (data) result (n) class(epa_data_t), intent(in) :: data integer :: n end function epa_data_get_n_par <>= module function epa_data_get_n_par (data) result (n) class(epa_data_t), intent(in) :: data integer :: n if (data%recoil) then n = 3 else n = 1 end if end function epa_data_get_n_par @ %def epa_data_get_n_par @ Return the outgoing particles PDG codes. The outgoing particle is always the photon while the radiated particle is identical to the incoming one. <>= procedure :: get_pdg_out => epa_data_get_pdg_out <>= module subroutine epa_data_get_pdg_out (data, pdg_out) class(epa_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out end subroutine epa_data_get_pdg_out <>= module subroutine epa_data_get_pdg_out (data, pdg_out) class(epa_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = PHOTON end subroutine epa_data_get_pdg_out @ %def epa_data_get_pdg_out @ Allocate the interaction record. Gfortran 7/8/9 bug, has to remain in module. <>= procedure :: allocate_sf_int => epa_data_allocate_sf_int <>= subroutine epa_data_allocate_sf_int (data, sf_int) class(epa_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (epa_t :: sf_int) end subroutine epa_data_allocate_sf_int @ %def epa_data_allocate_sf_int @ \subsection{The EPA object} The [[epa_t]] data type is a $1\to 2$ interaction. We should be able to handle several flavors in parallel, since EPA is not necessarily applied immediately after beam collision: Photons may be radiated from quarks. In that case, the partons are massless and $q_{\rm min}$ applies instead, so we do not need to generate several kinematical configurations in parallel. The squared charge values multiply the matrix elements, depending on the flavour. We scan the interaction after building it, so we have the correct assignments. The particles are ordered as (incoming, radiated, photon), where the photon initiates the hard interaction. We generate an unpolarized photon and transfer initial polarization to the radiated parton. Color is transferred in the same way. <>= type, extends (sf_int_t) :: epa_t type(epa_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: xb = 0 real(default) :: E = 0 real(default), dimension(:), allocatable :: charge2 contains <> end type epa_t @ %def epa_t @ Type string: has to be here, but there is no string variable on which EPA depends. Hence, a dummy routine. <>= procedure :: type_string => epa_type_string <>= module function epa_type_string (object) result (string) class(epa_t), intent(in) :: object type(string_t) :: string end function epa_type_string <>= module function epa_type_string (object) result (string) class(epa_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "EPA: equivalent photon approx." else string = "EPA: [undefined]" end if end function epa_type_string @ %def epa_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => epa_write <>= module subroutine epa_write (object, unit, testflag) class(epa_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine epa_write <>= module subroutine epa_write (object, unit, testflag) class(epa_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_17 // ")") "x =", object%x if (object%status >= SF_FAILED_EVALUATION) then write (u, "(3x,A," // FMT_17 // ")") "E =", object%E end if end if call object%base_write (u, testflag) else write (u, "(1x,A)") "EPA data: [undefined]" end if end subroutine epa_write @ %def epa_write @ Prepare the interaction object. We have to construct transition matrix elements for all flavor and helicity combinations. <>= procedure :: init => epa_init <>= module subroutine epa_init (sf_int, data) class(epa_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data end subroutine epa_init <>= module subroutine epa_init (sf_int, data) class(epa_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask integer, dimension(3) :: hel_lock type(polarization_t), target :: pol type(quantum_numbers_t), dimension(1) :: qn_fc type(flavor_t) :: flv_photon type(color_t) :: col_photon type(quantum_numbers_t) :: qn_hel, qn_photon, qn, qn_rad type(polarization_iterator_t) :: it_hel integer :: i mask = quantum_numbers_mask (.false., .false., & mask_h = [.false., .false., .true.]) hel_lock = [2, 1, 0] select type (data) type is (epa_data_t) call sf_int%base_init (mask, [data%mass**2], & [data%mass**2], [0._default], hel_lock = hel_lock) sf_int%data => data call flv_photon%init (PHOTON, data%model) call col_photon%init () call qn_photon%init (flv_photon, col_photon) do i = 1, size (data%flv_in) call pol%init_generic (data%flv_in(i)) call qn_fc(1)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i), 1)) call it_hel%init (pol) do while (it_hel%is_valid ()) qn_hel = it_hel%get_quantum_numbers () qn = qn_hel .merge. qn_fc(1) qn_rad = qn call qn_rad%tag_radiated () call sf_int%add_state ([qn, qn_rad, qn_photon]) call it_hel%advance () end do ! call pol%final () end do call sf_int%freeze () if (data%keep_energy) then sf_int%on_shell_mode = KEEP_ENERGY else sf_int%on_shell_mode = KEEP_MOMENTUM end if call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) end select end subroutine epa_init @ %def epa_init @ Prepare the charge array. This is separate from the previous routine since the state matrix may be helicity-contracted. <>= procedure :: setup_constants => epa_setup_constants <>= module subroutine epa_setup_constants (sf_int) class(epa_t), intent(inout), target :: sf_int end subroutine epa_setup_constants <>= module subroutine epa_setup_constants (sf_int) class(epa_t), intent(inout), target :: sf_int type(state_iterator_t) :: it type(flavor_t) :: flv integer :: i, n_me n_me = sf_int%get_n_matrix_elements () allocate (sf_int%charge2 (n_me)) call it%init (sf_int%interaction_t%get_state_matrix_ptr ()) do while (it%is_valid ()) i = it%get_me_index () flv = it%get_flavor (1) sf_int%charge2(i) = flv%get_charge () ** 2 call it%advance () end do sf_int%status = SF_INITIAL end subroutine epa_setup_constants @ %def epa_setup_constants @ \subsection{Kinematics} Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. The EPA structure function allows for a straightforward mapping of the unit interval. The $x$ value is transformed, and the mapped structure function becomes unity at its upper boundary. The structure function implementation applies the above mapping to the input (random) number [[r]] to generate the momentum fraction [[x]] and the function value [[f]]. For numerical stability reasons, we also output [[xb]], which is $\bar x=1-x$. <>= procedure :: complete_kinematics => epa_complete_kinematics <>= module subroutine epa_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(epa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map end subroutine epa_complete_kinematics <>= module subroutine epa_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(epa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map real(default) :: delta, sqrt_delta, lx if (map) then associate (data => sf_int%data) delta = data%log ** 2 - 4 * (r(1) * data%c1 + rb(1) * data%c0) if (delta > 0) then sqrt_delta = sqrt (delta) lx = (data%log - sqrt_delta) / 2 else sf_int%status = SF_FAILED_KINEMATICS f = 0 return end if x(1) = exp (lx) f = x(1) * data%dc / sqrt_delta end associate else x(1) = r(1) if (sf_int%data%x_min < x(1) .and. x(1) < sf_int%data%x_max) then f = 1 else sf_int%status = SF_FAILED_KINEMATICS f = 0 return end if end if xb(1) = 1 - x(1) if (size(x) == 3) then x(2:3) = r(2:3) xb(2:3) = rb(2:3) end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_DONE_KINEMATICS) sf_int%x = x(1) sf_int%xb= xb(1) sf_int%E = energy (sf_int%get_momentum (1)) case (SF_FAILED_KINEMATICS) sf_int%x = 0 sf_int%xb= 0 f = 0 end select end subroutine epa_complete_kinematics @ %def epa_complete_kinematics @ Overriding the default method: we compute the [[x]] array from the momentum configuration. In the specific case of EPA, we also set the internally stored $x$ and $\bar x$ values, so they can be used in the following routine. Note: the extraction of $\bar x$ is not numerically safe, but it cannot be as long as the base [[recover_x]] is not. <>= procedure :: recover_x => sf_epa_recover_x <>= module subroutine sf_epa_recover_x (sf_int, x, xb, x_free) class(epa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free end subroutine sf_epa_recover_x <>= module subroutine sf_epa_recover_x (sf_int, x, xb, x_free) class(epa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) sf_int%xb = xb(1) end subroutine sf_epa_recover_x @ %def sf_epa_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => epa_inverse_kinematics <>= module subroutine epa_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(epa_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta end subroutine epa_inverse_kinematics <>= module subroutine epa_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(epa_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default) :: lx, delta, sqrt_delta, c logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then associate (data => sf_int%data) lx = log (x(1)) sqrt_delta = data%log - 2 * lx delta = sqrt_delta ** 2 c = (data%log ** 2 - delta) / 4 r (1) = (c - data%c0) / data%dc rb(1) = (data%c1 - c) / data%dc f = x(1) * data%dc / sqrt_delta end associate else r (1) = x(1) rb(1) = xb(1) if (sf_int%data%x_min < x(1) .and. x(1) < sf_int%data%x_max) then f = 1 else f = 0 end if end if if (size(r) == 3) then r (2:3) = x(2:3) rb(2:3) = xb(2:3) end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if sf_int%E = energy (sf_int%get_momentum (1)) end subroutine epa_inverse_kinematics @ %def epa_inverse_kinematics @ \subsection{EPA application} For EPA, we can in principle compute kinematics and function value in a single step. In order to be able to reweight events, kinematics and structure function application are separated. This function works on a single beam, assuming that the input momentum has been set. We need three random numbers as input: one for $x$, and two for the polar and azimuthal angles. Alternatively, for the no-recoil case, we can skip $p_T$ generation; in this case, we only need one. For obtaining splitting kinematics, we rely on the assumption that all in-particles are mass-degenerate (or there is only one), so the generated $x$ values are identical. Fix 2020-03-10: Divide by two if there is polarization. In the polarized case, the outgoing electron/positron retains the incoming polarization. The latter is summed over when convoluting with the beam, but there are still two states with different outgoing polarization but identical structure-function value. This leads to double-counting for the overall cross section. Fix 2022-02-18: The above fix was wrong! The structure function was divided by 4 because there are four entries in the complete electron density matrix. Now it is divided by 2 if there is more than one entry, unchanged otherwise. <>= procedure :: apply => epa_apply <>= module subroutine epa_apply (sf_int, scale, negative_sf, rescale, i_sub) class(epa_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub end subroutine epa_apply <>= module subroutine epa_apply (sf_int, scale, negative_sf, rescale, i_sub) class(epa_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: x, xb, qminsq, qmaxsq, f, E, m2 associate (data => sf_int%data) x = sf_int%x xb= sf_int%xb E = sf_int%E m2 = data%mass ** 2 qminsq = max (x ** 2 / xb * data%mass ** 2, data%q_min ** 2) select case (data%mode) case (0) qmaxsq = min (4 * xb * E ** 2, data%q_max ** 2) if (qminsq < qmaxsq) then f = data%a / x & * ((xb + x ** 2 / 2) * log (qmaxsq / qminsq) & - (1 - x / 2) ** 2 & * log ((x**2 + qmaxsq / E ** 2) / (x**2 + qminsq / E ** 2)) & - x ** 2 * data%mass ** 2 / qminsq * (1 - qminsq / qmaxsq)) else f = 0 end if case (1) qmaxsq = min (4 * xb * E ** 2, data%q_max ** 2) if (qminsq < qmaxsq) then f = data%a / x & * ((xb + x ** 2 / 2) * log (qmaxsq / qminsq) & - x ** 2 * data%mass ** 2 / qminsq * (1 - qminsq / qmaxsq)) else f = 0 end if case (2) qmaxsq = data%q_max ** 2 if (data%mass ** 2 < qmaxsq) then f = data%a / x & * ((xb + x ** 2 / 2) * log (qmaxsq / m2) & - x ** 2 * data%mass ** 2 / qminsq * (1 - qminsq / qmaxsq)) else f = 0 end if case (3) qmaxsq = data%q_max ** 2 if (data%mass ** 2 < qmaxsq) then f = data%a / x & * ((xb + x ** 2 / 2) * log (qmaxsq / m2) & - x ** 2 * (1 - m2 / qmaxsq)) else f = 0 end if case (4) qmaxsq = data%q_max ** 2 if (data%mass ** 2 < qmaxsq) then f = data%a / x & * ((xb + x ** 2 / 2) * log (qmaxsq / m2)) else f = 0 end if end select if (sf_int%get_n_matrix_elements () > 1) then f = f / 2 end if call sf_int%set_matrix_element & (cmplx (f, kind=default) * sf_int%charge2) end associate sf_int%status = SF_EVALUATED end subroutine epa_apply @ %def epa_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_epa_ut.f90]]>>= <> module sf_epa_ut use unit_tests use sf_epa_uti <> <> contains <> end module sf_epa_ut @ %def sf_epa_ut @ <<[[sf_epa_uti.f90]]>>= <> module sf_epa_uti <> use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use sf_aux use sf_base use sf_epa <> <> contains <> end module sf_epa_uti @ %def sf_epa_ut @ API: driver for the unit tests below. <>= public :: sf_epa_test <>= subroutine sf_epa_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_epa_test @ %def sf_epa_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_epa_1, "sf_epa_1", & "structure function configuration", & u, results) <>= public :: sf_epa_1 <>= subroutine sf_epa_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_epa_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_qed_test () pdg_in = ELECTRON allocate (epa_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") select type (data) type is (epa_data_t) call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, & 10._default, 100._default, 0.000511_default, recoil = .false.) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_1" end subroutine sf_epa_1 @ %def sf_epa_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the EPA structure function. <>= call test (sf_epa_2, "sf_epa_2", & "structure function instance", & u, results) <>= public :: sf_epa_2 <>= subroutine sf_epa_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_epa_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (epa_data_t :: data) select type (data) type is (epa_data_t) call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, & 10._default, 100._default, 0.000511_default, recoil = .false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, no EPA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false., & set_momenta=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EPA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_2" end subroutine sf_epa_2 @ %def sf_epa_2 @ \subsubsection{Standard mapping} Construct and display a structure function object based on the EPA structure function, applying the standard single-particle mapping. <>= call test (sf_epa_3, "sf_epa_3", & "apply mapping", & u, results) <>= public :: sf_epa_3 <>= subroutine sf_epa_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_epa_3" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (epa_data_t :: data) select type (data) type is (epa_data_t) call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, & 10._default, 100._default, 0.000511_default, recoil = .false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, with EPA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., & set_momenta=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EPA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_3" end subroutine sf_epa_3 @ %def sf_epa_3 @ \subsubsection{Non-collinear case} Construct and display a structure function object based on the EPA structure function. <>= call test (sf_epa_4, "sf_epa_4", & "non-collinear", & u, results) <>= public :: sf_epa_4 <>= subroutine sf_epa_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E, m real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_epa_4" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (epa_data_t :: data) select type (data) type is (epa_data_t) call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, & 10._default, 100._default, 5.0_default, recoil = .true.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=500, me = 5 GeV" write (u, "(A)") E = 500 m = 5 k = vector4_moving (E, sqrt (E**2 - m**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.5/0.5/0.25, with EPA mapping, " write (u, "(A)") " non-coll., keeping energy, me = 5 GeV" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.5_default, 0.5_default, 0.25_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%pacify_momenta (1e-10_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x and r from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., & set_momenta=.true.) call sf_int%pacify_momenta (1e-10_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EPA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_4" end subroutine sf_epa_4 @ %def sf_epa_4 @ \subsubsection{Structure function for multiple flavors} Construct and display a structure function object based on the EPA structure function. The incoming state has multiple particles with non-uniform charge. <>= call test (sf_epa_5, "sf_epa_5", & "multiple flavors", & u, results) <>= public :: sf_epa_5 <>= subroutine sf_epa_5 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_epa_5" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (1, model) pdg_in = [1, 2, -1, -2] call reset_interaction_counter () allocate (epa_data_t :: data) select type (data) type is (epa_data_t) call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, & 10._default, 100._default, 0.000511_default, recoil = .false.) call data%check () end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, no EPA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EPA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_5" end subroutine sf_epa_5 @ %def sf_epa_5 @ \clearpage %------------------------------------------------------------------------ \section{EWA} <<[[sf_ewa.f90]]>>= <> module sf_ewa <> <> use pdg_arrays use model_data use flavors use quantum_numbers use state_matrices use polarizations use interactions use sf_aux use sf_base <> <> <> <> interface <> end interface contains <> end module sf_ewa @ %def sf_ewa @ <<[[sf_ewa_sub.f90]]>>= <> submodule (sf_ewa) sf_ewa_s use io_units use constants, only: pi use format_defs, only: FMT_17, FMT_19 use numeric_utils use diagnostics use physics_defs, only: W_BOSON, Z_BOSON use lorentz use colors implicit none contains <> end submodule sf_ewa_s @ %def sf_ewa_s @ \subsection{Physics} The EWA structure function for a $Z$ or $W$ inside a fermion (lepton or quark) depends on the vector-boson polarization. We distinguish transversal ($\pm$) and longitudinal ($0$) polarization. \begin{align} F_{+}(x) &= \frac{1}{16\pi^2}\,\frac{(v-a)^2 + (v+a)^2\bar x^2}{x} \left[ \ln\left(\frac{p_{\perp,\textrm{max}}^2 + \bar x M^2}{\bar x M^2}\right) - \frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2} \right] \\ F_{-}(x) &= \frac{1}{16\pi^2}\,\frac{(v+a)^2 + (v-a)^2\bar x^2}{x} \left[ \ln\left(\frac{p_{\perp,\textrm{max}}^2 + \bar x M^2}{\bar x M^2}\right) - \frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2} \right] \\ F_0(x) &= \frac{v^2+a^2}{8\pi^2}\,\frac{2\bar x}{x}\, \frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2} \end{align} where $p_{\perp,\textrm{max}}$ is the cutoff in transversal momentum, $M$ is the vector-boson mass, $v$ and $a$ are the vector and axial-vector couplings, and $\bar x\equiv 1-x$. Note that the longitudinal structure function is finite for large cutoff, while the transversal structure function is logarithmically divergent. The maximal transverse momentum is given by the kinematical limit, it is \begin{equation} p_{\perp,\textrm{max}} = \bar x \sqrt{s}/2. \end{equation} The vector and axial couplings for a fermion branching into a $W$ are \begin{align} v_W &= \frac{g}{2\sqrt 2}, & a_W &= \frac{g}{2\sqrt 2}. \end{align} For $Z$ emission, this is replaced by \begin{align} v_Z &= \frac{g}{2\cos\theta_w}\left(t_3 - 2q\sin^2\theta_w\right), & a_Z &= \frac{g}{2\cos\theta_w}t_3, \end{align} where $t_3=\pm\frac12$ is the fermion isospin, and $q$ its charge. For an initial antifermion, the signs of the axial couplings are inverted. Note that a common sign change of $v$ and $a$ is irrelevant. %% Differentiating with respect to the cutoff, we get structure functions %% \begin{align} %% f_{W,\pm}(x,p_T) &= \frac{g^2}{16\pi^2}\, %% \frac{1+\bar x^2}{x} %% \frac{p_\perp}{p_\perp^2 + \bar x M^2} %% \\ %% f_{W,0}(x,p_T) &= \frac{g^2}{16\pi^2}\, %% \frac{2\bar x}{x}\, %% \frac{p_\perp \bar xM^2}{(p_\perp^2 + \bar x M^2)^2} %% \\ %% F_{Z,\pm}(x,p_T) &= \frac{g^2}{16\pi^2\cos\theta_w^2} %% \left[(t_3^f-2q^2\sin\theta_w^2)^2 + (t_3^f)^2\right]\, %% \frac{1+\bar x^2}{x} %% \frac{p_\perp}{p_\perp^2 + \bar x M^2} %% \\ %% F_{Z,0}(x,p_T) &= \frac{g^2}{16\pi^2\cos\theta_w^2}\, %% \left[(t_3^f-2q^2\sin\theta_w^2)^2 + (t_3^f)^2\right]\, %% \frac{2\bar x}{x}\, %% \frac{p_\perp \bar xM^2}{(p_\perp^2 + \bar x M^2)^2} %% \end{align} %% Here, $t_3^f$ is the $SU(2)_L$ quantum number of the fermion %% $(\pm\frac12)$, and $q^f$ is the fermion charge in units of the %% positron charge. The EWA depends on the parameters $g$, $\sin^2\theta_w$, $M_W$, and $M_Z$. These can all be taken from the SM input, and the prefactors are calculated from those and the incoming particle type. Since these structure functions have a $1/x$ singularity (which is not really relevant in practice, however, since the vector boson mass is finite), we map this singularity allowing for nontrivial $x$ bounds: \begin{equation} x = \exp(\bar r\ln x_0 + r\ln x_1) \end{equation} such that \begin{equation} \int_{x_0}^{x_1}\frac{dx}{x} = (\ln x_1 - \ln x_0)\int_0^1 dr. \end{equation} As a user parameter, we have the cutoff $p_{\perp,\textrm{max}}$. The divergence $1/x$ also requires a $x_0$ cutoff; and for completeness we introduce a corresponding $x_1$. Physically, the minimal sensible value of $x$ is $M^2/s$, although the approximation loses its value already at higher $x$ values. \subsection{The EWA data block} The EWA parameters are: $p_{T,\rm max}$, $c_V$, $c_A$, and $m$. Instead of $m$ we can use the incoming particle PDG code as input; from this we can deduce the mass and charges. In the initialization phase it is not yet determined whether a $W$ or a $Z$ is radiated, hence we set the vector and axial-vector couplings equal to the common prefactors $g/2 = e/2/\sin\theta_W$. In principle, for EWA it would make sense to allow the user to also set the upper bound for $x$, $x_{\rm max}$, but we fix it to one here. <>= public :: ewa_data_t <>= type, extends(sf_data_t) :: ewa_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(:), allocatable :: flv_in type(flavor_t), dimension(:), allocatable :: flv_out real(default) :: pt_max real(default) :: sqrts real(default) :: x_min real(default) :: x_max real(default) :: mass real(default) :: m_out real(default) :: q_min real(default) :: cv real(default) :: ca real(default) :: costhw real(default) :: sinthw real(default) :: mW real(default) :: mZ real(default) :: coeff logical :: mass_set = .false. logical :: recoil = .false. logical :: keep_energy = .false. integer :: id = 0 integer :: error = NONE contains <> end type ewa_data_t @ %def ewa_data_t @ Error codes <>= integer, parameter :: NONE = 0 integer, parameter :: ZERO_QMIN = 1 integer, parameter :: Q_MAX_TOO_SMALL = 2 integer, parameter :: ZERO_XMIN = 3 integer, parameter :: MASS_MIX = 4 integer, parameter :: ZERO_SW = 5 integer, parameter :: ISOSPIN_MIX = 6 integer, parameter :: WRONG_PRT = 7 integer, parameter :: MASS_MIX_OUT = 8 integer, parameter :: NO_EWA = 9 <>= procedure :: init => ewa_data_init <>= module subroutine ewa_data_init (data, model, pdg_in, x_min, pt_max, & sqrts, recoil, keep_energy, mass) class(ewa_data_t), intent(inout) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in real(default), intent(in) :: x_min, pt_max, sqrts logical, intent(in) :: recoil, keep_energy real(default), intent(in), optional :: mass end subroutine ewa_data_init <>= module subroutine ewa_data_init (data, model, pdg_in, x_min, pt_max, & sqrts, recoil, keep_energy, mass) class(ewa_data_t), intent(inout) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in real(default), intent(in) :: x_min, pt_max, sqrts logical, intent(in) :: recoil, keep_energy real(default), intent(in), optional :: mass real(default) :: g, ee integer :: n_flv, i data%model => model if (.not. any (pdg_in .match. & [1,2,3,4,5,6,11,13,15,-1,-2,-3,-4,-5,-6,-11,-13,-15])) then data%error = WRONG_PRT; return end if n_flv = pdg_in%get_length () allocate (data%flv_in (n_flv)) allocate (data%flv_out(n_flv)) do i = 1, n_flv call data%flv_in(i)%init (pdg_in%get (i), model) end do data%pt_max = pt_max data%sqrts = sqrts data%x_min = x_min data%x_max = 1 if (vanishes (data%x_min)) then data%error = ZERO_XMIN; return end if select case (char (data%model%get_name ())) case ("QCD","QED","Test") data%error = NO_EWA; return end select ee = data%model%get_real (var_str ("ee")) data%sinthw = data%model%get_real (var_str ("sw")) data%costhw = data%model%get_real (var_str ("cw")) data%mZ = data%model%get_real (var_str ("mZ")) data%mW = data%model%get_real (var_str ("mW")) if (data%sinthw /= 0) then g = ee / data%sinthw else data%error = ZERO_SW; return end if data%cv = g / 2._default data%ca = g / 2._default data%coeff = 1._default / (8._default * PI**2) data%recoil = recoil data%keep_energy = keep_energy if (present (mass)) then data%mass = mass data%m_out = mass data%mass_set = .true. else data%mass = data%flv_in(1)%get_mass () if (any (data%flv_in%get_mass () /= data%mass)) then data%error = MASS_MIX; return end if end if end subroutine ewa_data_init @ %def ewa_data_init @ Set the vector boson ID for distinguishing $W$ and $Z$ bosons. <>= procedure :: set_id => ewa_set_id <>= module subroutine ewa_set_id (data, id) class(ewa_data_t), intent(inout) :: data integer, intent(in) :: id end subroutine ewa_set_id <>= module subroutine ewa_set_id (data, id) class(ewa_data_t), intent(inout) :: data integer, intent(in) :: id integer :: i, isospin, pdg if (.not. allocated (data%flv_in)) & call msg_bug ("EWA: incoming particles not set") data%id = id select case (data%id) case (23) data%m_out = data%mass data%flv_out = data%flv_in case (24) do i = 1, size (data%flv_in) pdg = data%flv_in(i)%get_pdg () isospin = data%flv_in(i)%get_isospin_type () if (isospin > 0) then !!! up-type quark or neutrinos if (data%flv_in(i)%is_antiparticle ()) then call data%flv_out(i)%init (pdg + 1, data%model) else call data%flv_out(i)%init (pdg - 1, data%model) end if else !!! down-type quark or lepton if (data%flv_in(i)%is_antiparticle ()) then call data%flv_out(i)%init (pdg - 1, data%model) else call data%flv_out(i)%init (pdg + 1, data%model) end if end if end do if (.not. data%mass_set) then data%m_out = data%flv_out(1)%get_mass () if (any (data%flv_out%get_mass () /= data%m_out)) then data%error = MASS_MIX_OUT; return end if end if end select end subroutine ewa_set_id @ %def ewa_set_id @ Handle error conditions. Should always be done after initialization, unless we are sure everything is ok. <>= procedure :: check => ewa_data_check <>= module subroutine ewa_data_check (data) class(ewa_data_t), intent(in) :: data end subroutine ewa_data_check <>= module subroutine ewa_data_check (data) class(ewa_data_t), intent(in) :: data select case (data%error) case (WRONG_PRT) call msg_fatal ("EWA structure function only accessible for " & // "SM quarks and leptons.") case (NO_EWA) call msg_fatal ("EWA structure function not available for model " & // char (data%model%get_name ())) case (ZERO_SW) call msg_fatal ("EWA: Vanishing value of sin(theta_w)") case (ZERO_QMIN) call msg_fatal ("EWA: Particle mass is zero") case (Q_MAX_TOO_SMALL) call msg_fatal ("EWA: Particle mass exceeds Qmax") case (ZERO_XMIN) call msg_fatal ("EWA: x_min must be larger than zero") case (MASS_MIX) call msg_fatal ("EWA: incoming particle masses must be uniform") case (MASS_MIX_OUT) call msg_fatal ("EWA: outgoing particle masses must be uniform") case (ISOSPIN_MIX) call msg_fatal ("EWA: incoming particle isospins must be uniform") end select end subroutine ewa_data_check @ %def ewa_data_check @ Output <>= procedure :: write => ewa_data_write <>= module subroutine ewa_data_write (data, unit, verbose) class(ewa_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine ewa_data_write <>= module subroutine ewa_data_write (data, unit, verbose) class(ewa_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "EWA data:" if (allocated (data%flv_in) .and. allocated (data%flv_out)) then write (u, "(3x,A)", advance="no") " flavor(in) = " do i = 1, size (data%flv_in) if (i > 1) write (u, "(',',1x)", advance="no") call data%flv_in(i)%write (u) end do write (u, *) write (u, "(3x,A)", advance="no") " flavor(out) = " do i = 1, size (data%flv_out) if (i > 1) write (u, "(',',1x)", advance="no") call data%flv_out(i)%write (u) end do write (u, *) write (u, "(3x,A," // FMT_19 // ")") " x_min = ", data%x_min write (u, "(3x,A," // FMT_19 // ")") " x_max = ", data%x_max write (u, "(3x,A," // FMT_19 // ")") " pt_max = ", data%pt_max write (u, "(3x,A," // FMT_19 // ")") " sqrts = ", data%sqrts write (u, "(3x,A," // FMT_19 // ")") " mass = ", data%mass write (u, "(3x,A," // FMT_19 // ")") " cv = ", data%cv write (u, "(3x,A," // FMT_19 // ")") " ca = ", data%ca write (u, "(3x,A," // FMT_19 // ")") " coeff = ", data%coeff write (u, "(3x,A," // FMT_19 // ")") " costhw = ", data%costhw write (u, "(3x,A," // FMT_19 // ")") " sinthw = ", data%sinthw write (u, "(3x,A," // FMT_19 // ")") " mZ = ", data%mZ write (u, "(3x,A," // FMT_19 // ")") " mW = ", data%mW write (u, "(3x,A,L2)") " recoil = ", data%recoil write (u, "(3x,A,L2)") " keep en. = ", data%keep_energy write (u, "(3x,A,I2)") " PDG (VB) = ", data%id else write (u, "(3x,A)") "[undefined]" end if end subroutine ewa_data_write @ %def ewa_data_write @ The number of parameters is one for collinear splitting, in case the [[recoil]] option is set, we take the recoil into account. <>= procedure :: get_n_par => ewa_data_get_n_par <>= module function ewa_data_get_n_par (data) result (n) class(ewa_data_t), intent(in) :: data integer :: n end function ewa_data_get_n_par <>= module function ewa_data_get_n_par (data) result (n) class(ewa_data_t), intent(in) :: data integer :: n if (data%recoil) then n = 3 else n = 1 end if end function ewa_data_get_n_par @ %def ewa_data_get_n_par @ Return the outgoing particles PDG codes. This depends, whether this is a charged-current or neutral-current interaction. <>= procedure :: get_pdg_out => ewa_data_get_pdg_out <>= module subroutine ewa_data_get_pdg_out (data, pdg_out) class(ewa_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out end subroutine ewa_data_get_pdg_out <>= module subroutine ewa_data_get_pdg_out (data, pdg_out) class(ewa_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer, dimension(:), allocatable :: pdg1 integer :: i, n_flv if (allocated (data%flv_out)) then n_flv = size (data%flv_out) else n_flv = 0 end if allocate (pdg1 (n_flv)) do i = 1, n_flv pdg1(i) = data%flv_out(i)%get_pdg () end do pdg_out(1) = pdg1 end subroutine ewa_data_get_pdg_out @ %def ewa_data_get_pdg_out @ Allocate the interaction record. Due to a gfortran 7/8/9 bug, this has to remain in the main module. <>= procedure :: allocate_sf_int => ewa_data_allocate_sf_int <>= subroutine ewa_data_allocate_sf_int (data, sf_int) class(ewa_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (ewa_t :: sf_int) end subroutine ewa_data_allocate_sf_int @ %def ewa_data_allocate_sf_int @ \subsection{The EWA object} The [[ewa_t]] data type is a $1\to 2$ interaction. We should be able to handle several flavors in parallel, since EWA is not necessarily applied immediately after beam collision: $W/Z$ bosons may be radiated from quarks. In that case, the partons are massless and $q_{\rm min}$ applies instead, so we do not need to generate several kinematical configurations in parallel. The particles are ordered as (incoming, radiated, W/Z), where the W/Z initiates the hard interaction. In the case of EPA, we generated an unpolarized photon and transferred initial polarization to the radiated parton. Color is transferred in the same way. I do not know whether the same can/should be done for EWA, as the structure functions depend on the W/Z polarization. If we are having $Z$ bosons, both up- and down-type fermions can participate. Otherwise, with a $W^+$ an up-type fermion is transferred to a down-type fermion, and the other way round. <>= type, extends (sf_int_t) :: ewa_t type(ewa_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: xb = 0 integer :: n_me = 0 real(default), dimension(:), allocatable :: cv real(default), dimension(:), allocatable :: ca contains <> end type ewa_t @ %def ewa_t @ Type string: has to be here, but there is no string variable on which EWA depends. Hence, a dummy routine. <>= procedure :: type_string => ewa_type_string <>= module function ewa_type_string (object) result (string) class(ewa_t), intent(in) :: object type(string_t) :: string end function ewa_type_string <>= module function ewa_type_string (object) result (string) class(ewa_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "EWA: equivalent W/Z approx." else string = "EWA: [undefined]" end if end function ewa_type_string @ %def ewa_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => ewa_write <>= module subroutine ewa_write (object, unit, testflag) class(ewa_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine ewa_write <>= module subroutine ewa_write (object, unit, testflag) class(ewa_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_17 // ")") "x =", object%x write (u, "(3x,A," // FMT_17 // ")") "xb=", object%xb end if call object%base_write (u, testflag) else write (u, "(1x,A)") "EWA data: [undefined]" end if end subroutine ewa_write @ %def ewa_write @ The current implementation requires uniform isospin for all incoming particles, therefore we need to probe only the first one. <>= procedure :: init => ewa_init <>= module subroutine ewa_init (sf_int, data) class(ewa_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data end subroutine ewa_init <>= module subroutine ewa_init (sf_int, data) class(ewa_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask integer, dimension(3) :: hel_lock type(polarization_t), target :: pol type(quantum_numbers_t), dimension(1) :: qn_fc, qn_fc_fin type(flavor_t) :: flv_z, flv_wp, flv_wm type(color_t) :: col0 type(quantum_numbers_t) :: qn_hel, qn_z, qn_wp, qn_wm, qn, qn_rad, qn_w type(polarization_iterator_t) :: it_hel integer :: i, isospin select type (data) type is (ewa_data_t) mask = quantum_numbers_mask (.false., .false., & mask_h = [.false., .false., .true.]) hel_lock = [2, 1, 0] call col0%init () select case (data%id) case (23) !!! Z boson, flavor is not changing call sf_int%base_init (mask, [data%mass**2], [data%mass**2], & [data%mZ**2], hel_lock = hel_lock) sf_int%data => data call flv_z%init (Z_BOSON, data%model) call qn_z%init (flv_z, col0) do i = 1, size (data%flv_in) call pol%init_generic (data%flv_in(i)) call qn_fc(1)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i), 1)) call it_hel%init (pol) do while (it_hel%is_valid ()) qn_hel = it_hel%get_quantum_numbers () qn = qn_hel .merge. qn_fc(1) qn_rad = qn call qn_rad%tag_radiated () call sf_int%add_state ([qn, qn_rad, qn_z]) call it_hel%advance () end do ! call pol%final () end do case (24) call sf_int%base_init (mask, [data%mass**2], [data%m_out**2], & [data%mW**2], hel_lock = hel_lock) sf_int%data => data call flv_wp%init (W_BOSON, data%model) call flv_wm%init (- W_BOSON, data%model) call qn_wp%init (flv_wp, col0) call qn_wm%init (flv_wm, col0) do i = 1, size (data%flv_in) isospin = data%flv_in(i)%get_isospin_type () if (isospin > 0) then !!! up-type quark or neutrinos if (data%flv_in(i)%is_antiparticle ()) then qn_w = qn_wm else qn_w = qn_wp end if else !!! down-type quark or lepton if (data%flv_in(i)%is_antiparticle ()) then qn_w = qn_wp else qn_w = qn_wm end if end if call pol%init_generic (data%flv_in(i)) call qn_fc(1)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i), 1)) call qn_fc_fin(1)%init ( & flv = data%flv_out(i), & col = color_from_flavor (data%flv_out(i), 1)) call it_hel%init (pol) do while (it_hel%is_valid ()) qn_hel = it_hel%get_quantum_numbers () qn = qn_hel .merge. qn_fc(1) qn_rad = qn_hel .merge. qn_fc_fin(1) call qn_rad%tag_radiated () call sf_int%add_state ([qn, qn_rad, qn_w]) call it_hel%advance () end do ! call pol%final () end do case default call msg_fatal ("EWA initialization failed: wrong particle type.") end select call sf_int%freeze () if (data%keep_energy) then sf_int%on_shell_mode = KEEP_ENERGY else sf_int%on_shell_mode = KEEP_MOMENTUM end if call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) end select end subroutine ewa_init @ %def ewa_init @ Prepare the coupling arrays. This is separate from the previous routine since the state matrix may be helicity-contracted. <>= procedure :: setup_constants => ewa_setup_constants <>= module subroutine ewa_setup_constants (sf_int) class(ewa_t), intent(inout), target :: sf_int end subroutine ewa_setup_constants <>= module subroutine ewa_setup_constants (sf_int) class(ewa_t), intent(inout), target :: sf_int type(state_iterator_t) :: it type(flavor_t) :: flv real(default) :: q, t3 integer :: i sf_int%n_me = sf_int%get_n_matrix_elements () allocate (sf_int%cv (sf_int%n_me)) allocate (sf_int%ca (sf_int%n_me)) associate (data => sf_int%data) select case (data%id) case (23) call it%init (sf_int%interaction_t%get_state_matrix_ptr ()) do while (it%is_valid ()) i = it%get_me_index () flv = it%get_flavor (1) q = flv%get_charge () t3 = flv%get_isospin () if (flv%is_antiparticle ()) then sf_int%cv(i) = - data%cv & * (t3 - 2._default * q * data%sinthw**2) / data%costhw sf_int%ca(i) = data%ca * t3 / data%costhw else sf_int%cv(i) = data%cv & * (t3 - 2._default * q * data%sinthw**2) / data%costhw sf_int%ca(i) = data%ca * t3 / data%costhw end if call it%advance () end do case (24) call it%init (sf_int%interaction_t%get_state_matrix_ptr ()) do while (it%is_valid ()) i = it%get_me_index () flv = it%get_flavor (1) if (flv%is_antiparticle ()) then sf_int%cv(i) = data%cv / sqrt(2._default) sf_int%ca(i) = - data%ca / sqrt(2._default) else sf_int%cv(i) = data%cv / sqrt(2._default) sf_int%ca(i) = data%ca / sqrt(2._default) end if call it%advance () end do end select end associate sf_int%status = SF_INITIAL end subroutine ewa_setup_constants @ %def ewa_setup_constants @ \subsection{Kinematics} Set kinematics. The EWA structure function allows for a straightforward mapping of the unit interval. So, to leading order, the structure function value is unity, but the $x$ value is transformed. Higher orders affect the function value. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, the exponential mapping for the $1/x$ singularity discussed above is applied. <>= procedure :: complete_kinematics => ewa_complete_kinematics <>= module subroutine ewa_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(ewa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map end subroutine ewa_complete_kinematics <>= module subroutine ewa_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(ewa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map real(default) :: e_1 real(default) :: x0, x1, lx0, lx1, lx e_1 = energy (sf_int%get_momentum (1)) if (sf_int%data%recoil) then select case (sf_int%data%id) case (23) x0 = max (sf_int%data%x_min, sf_int%data%mz / e_1) case (24) x0 = max (sf_int%data%x_min, sf_int%data%mw / e_1) end select else x0 = sf_int%data%x_min end if x1 = sf_int%data%x_max if ( x0 >= x1) then f = 0 sf_int%status = SF_FAILED_KINEMATICS return end if if (map) then lx0 = log (x0) lx1 = log (x1) lx = lx1 * r(1) + lx0 * rb(1) x(1) = exp(lx) f = x(1) * (lx1 - lx0) else x(1) = r(1) if (x0 < x(1) .and. x(1) < x1) then f = 1 else sf_int%status = SF_FAILED_KINEMATICS f = 0 return end if end if xb(1) = 1 - x(1) if (size(x) == 3) then x(2:3) = r(2:3) xb(2:3) = rb(2:3) end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_DONE_KINEMATICS) sf_int%x = x(1) sf_int%xb = xb(1) case (SF_FAILED_KINEMATICS) sf_int%x = 0 sf_int%xb = 0 f = 0 end select end subroutine ewa_complete_kinematics @ %def ewa_complete_kinematics @ Overriding the default method: we compute the [[x]] array from the momentum configuration. In the specific case of EWA, we also set the internally stored $x$ and $\bar x$ values, so they can be used in the following routine. <>= procedure :: recover_x => sf_ewa_recover_x <>= module subroutine sf_ewa_recover_x (sf_int, x, xb, x_free) class(ewa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free end subroutine sf_ewa_recover_x <>= module subroutine sf_ewa_recover_x (sf_int, x, xb, x_free) class(ewa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) sf_int%xb = xb(1) end subroutine sf_ewa_recover_x @ %def sf_ewa_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => ewa_inverse_kinematics <>= module subroutine ewa_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(ewa_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta end subroutine ewa_inverse_kinematics <>= module subroutine ewa_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(ewa_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default) :: x0, x1, lx0, lx1, lx, e_1 logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta e_1 = energy (sf_int%get_momentum (1)) if (sf_int%data%recoil) then select case (sf_int%data%id) case (23) x0 = max (sf_int%data%x_min, sf_int%data%mz / e_1) case (24) x0 = max (sf_int%data%x_min, sf_int%data%mw / e_1) end select else x0 = sf_int%data%x_min end if x1 = sf_int%data%x_max if (map) then lx0 = log (x0) lx1 = log (x1) lx = log (x(1)) r(1) = (lx - lx0) / (lx1 - lx0) rb(1) = (lx1 - lx) / (lx1 - lx0) f = x(1) * (lx1 - lx0) else r (1) = x(1) rb(1) = 1 - x(1) if (x0 < x(1) .and. x(1) < x1) then f = 1 else f = 0 end if end if if (size(r) == 3) then r (2:3) = x(2:3) rb(2:3) = xb(2:3) end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine ewa_inverse_kinematics @ %def ewa_inverse_kinematics @ \subsection{EWA application} For EWA, we can compute kinematics and function value in a single step. This function works on a single beam, assuming that the input momentum has been set. We need four random numbers as input: one for $x$, one for $Q^2$, and two for the polar and azimuthal angles. Alternatively, we can skip $p_T$ generation; in this case, we only need one. For obtaining splitting kinematics, we rely on the assumption that all in-particles are mass-degenerate (or there is only one), so the generated $x$ values are identical. <>= procedure :: apply => ewa_apply <>= module subroutine ewa_apply (sf_int, scale, negative_sf, rescale, i_sub) class(ewa_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub end subroutine ewa_apply <>= module subroutine ewa_apply (sf_int, scale, negative_sf, rescale, i_sub) class(ewa_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: x, xb, pt2, c1, c2 real(default) :: cv, ca real(default) :: f, fm, fp, fL integer :: i associate (data => sf_int%data) x = sf_int%x xb = sf_int%xb pt2 = min ((data%pt_max)**2, (xb * data%sqrts / 2)**2) select case (data%id) case (23) !!! Z boson structure function c1 = log (1 + pt2 / (xb * (data%mZ)**2)) c2 = 1 / (1 + (xb * (data%mZ)**2) / pt2) case (24) !!! W boson structure function c1 = log (1 + pt2 / (xb * (data%mW)**2)) c2 = 1 / (1 + (xb * (data%mW)**2) / pt2) end select do i = 1, sf_int%n_me cv = sf_int%cv(i) ca = sf_int%ca(i) fm = data%coeff * & ((cv + ca)**2 + ((cv - ca) * xb)**2) * (c1 - c2) / (2 * x) fp = data%coeff * & ((cv - ca)**2 + ((cv + ca) * xb)**2) * (c1 - c2) / (2 * x) fL = data%coeff * & (cv**2 + ca**2) * (2 * xb / x) * c2 f = fp + fm + fL if (.not. vanishes (f)) then fp = fp / f fm = fm / f fL = fL / f end if call sf_int%set_matrix_element (i, cmplx (f, kind=default)) end do end associate sf_int%status = SF_EVALUATED end subroutine ewa_apply @ %def ewa_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_ewa_ut.f90]]>>= <> module sf_ewa_ut use unit_tests use sf_ewa_uti <> <> contains <> end module sf_ewa_ut @ %def sf_ewa_ut @ <<[[sf_ewa_uti.f90]]>>= <> module sf_ewa_uti <> use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use sf_aux use sf_base use sf_ewa <> <> contains <> end module sf_ewa_uti @ %def sf_ewa_ut @ API: driver for the unit tests below. <>= public :: sf_ewa_test <>= subroutine sf_ewa_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_ewa_test @ %def sf_ewa_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_ewa_1, "sf_ewa_1", & "structure function configuration", & u, results) <>= public :: sf_ewa_1 <>= subroutine sf_ewa_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_ewa_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_sm_test () pdg_in = 2 allocate (ewa_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize for Z boson" write (u, "(A)") select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 5000._default, .false., .false.) call data%set_id (23) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 write (u, "(A)") write (u, "(A)") "* Initialize for W boson" write (u, "(A)") deallocate (data) allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 5000._default, .false., .false.) call data%set_id (24) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_1" end subroutine sf_ewa_1 @ %def sf_ewa_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the EWA structure function. <>= call test (sf_ewa_2, "sf_ewa_2", & "structure function instance", & u, results) <>= public :: sf_ewa_2 <>= subroutine sf_ewa_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_ewa_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (2, model) pdg_in = 2 call reset_interaction_counter () allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 3000._default, .false., .true.) call data%set_id (24) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=1500" write (u, "(A)") E = 1500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, no EWA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false., & set_momenta=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EWA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_2" end subroutine sf_ewa_2 @ %def sf_ewa_2 @ \subsubsection{Standard mapping} Construct and display a structure function object based on the EWA structure function, applying the standard single-particle mapping. <>= call test (sf_ewa_3, "sf_ewa_3", & "apply mapping", & u, results) <>= public :: sf_ewa_3 <>= subroutine sf_ewa_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_ewa_3" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (2, model) pdg_in = 2 call reset_interaction_counter () allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 3000._default, .false., .true.) call data%set_id (24) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=1500" write (u, "(A)") E = 1500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, with EWA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., & set_momenta=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EWA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_3" end subroutine sf_ewa_3 @ %def sf_ewa_3 @ \subsubsection{Non-collinear case} Construct and display a structure function object based on the EPA structure function. <>= call test (sf_ewa_4, "sf_ewa_4", & "non-collinear", & u, results) <>= public :: sf_ewa_4 <>= subroutine sf_ewa_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_ewa_4" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call modeL%init_sm_test () call flv%init (2, model) pdg_in = 2 call reset_interaction_counter () allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 3000.0_default, .true., .true.) call data%set_id (24) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=1500" write (u, "(A)") E = 1500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.5/0.5/0.25, with EWA mapping, " write (u, "(A)") " non-coll., keeping energy" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.5_default, 0.5_default, 0.25_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%pacify_momenta (1e-10_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x and r from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., & set_momenta=.true.) call sf_int%pacify_momenta (1e-10_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EWA structure function" write (u, "(A)") call sf_int%apply (scale = 1500._default) call sf_int%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_4" end subroutine sf_ewa_4 @ %def sf_ewa_4 @ \subsubsection{Structure function for multiple flavors} Construct and display a structure function object based on the EWA structure function. The incoming state has multiple particles with non-uniform quantum numbers. <>= call test (sf_ewa_5, "sf_ewa_5", & "structure function instance", & u, results) <>= public :: sf_ewa_5 <>= subroutine sf_ewa_5 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_ewa_5" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (2, model) pdg_in = [1, 2, -1, -2] call reset_interaction_counter () allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 3000._default, .false., .true.) call data%set_id (24) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=1500" write (u, "(A)") E = 1500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, no EWA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EWA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_5" end subroutine sf_ewa_5 @ %def sf_ewa_5 @ \clearpage %------------------------------------------------------------------------ \section{Energy-scan spectrum} This spectrum is actually a trick that allows us to plot the c.m.\ energy dependence of a cross section without scanning the input energy. We start with the observation that a spectrum $f(x)$, applied to one of the incoming beams only, results in a cross section \begin{equation} \sigma = \int dx\,f(x)\,\hat\sigma(xs). \end{equation} We want to compute the distribution of $E=\sqrt{\hat s}=\sqrt{xs}$, i.e., \begin{equation} \frac{d\sigma}{dE} = \frac{2\sqrt{x}}{\sqrt{s}}\,\frac{d\sigma}{dx} = \frac{2\sqrt{x}}{\sqrt{s}}\,f(x)\,\hat\sigma(xs), \end{equation} so if we set \begin{equation} f(x) = \frac{\sqrt{s}}{2\sqrt{x}}, \end{equation} we get the distribution \begin{equation} \frac{d\sigma}{dE} = \hat\sigma(\hat s=E^2). \end{equation} We implement this as a spectrum with a single parameter $x$. The parameters for the individual beams are computed as $x_i=\sqrt{x}$, so they are equal and the kinematics is always symmetric. <<[[sf_escan.f90]]>>= <> module sf_escan <> <> use pdg_arrays use model_data use flavors use quantum_numbers use state_matrices use polarizations use sf_base <> <> <> interface <> end interface contains <> end module sf_escan @ %def sf_escan @ <<[[sf_escan_sub.f90]]>>= <> submodule (sf_escan) sf_escan_s use io_units use format_defs, only: FMT_12 use numeric_utils use diagnostics use lorentz implicit none contains <> end submodule sf_escan_s @ %def sf_escan_s @ \subsection{Data type} The [[norm]] is unity if the total cross section should be normalized to one, and $\sqrt{s}$ if it should be normalized to the total energy. In the latter case, the differential distribution $d\sigma/d\sqrt{\hat s}$ coincides with the partonic cross section $\hat\sigma$ as a function of $\sqrt{\hat s}$. <>= public :: escan_data_t <>= type, extends(sf_data_t) :: escan_data_t private type(flavor_t), dimension(:,:), allocatable :: flv_in integer, dimension(2) :: n_flv = 0 real(default) :: norm = 1 contains <> end type escan_data_t @ %def escan_data_t <>= procedure :: init => escan_data_init <>= module subroutine escan_data_init (data, model, pdg_in, norm) class(escan_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), intent(in), optional :: norm end subroutine escan_data_init <>= module subroutine escan_data_init (data, model, pdg_in, norm) class(escan_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), intent(in), optional :: norm real(default), dimension(2) :: m2 integer :: i, j data%n_flv = pdg_in%get_length () allocate (data%flv_in (maxval (data%n_flv), 2)) do i = 1, 2 do j = 1, data%n_flv(i) call data%flv_in(j, i)%init (pdg_in(i)%get (j), model) end do end do m2 = data%flv_in(1,:)%get_mass () do i = 1, 2 if (.not. any (nearly_equal (data%flv_in(1:data%n_flv(i),i)%get_mass (), m2(i)))) then call msg_fatal ("Energy scan: incoming particle mass must be uniform") end if end do if (present (norm)) data%norm = norm end subroutine escan_data_init @ %def escan_data_init @ Output <>= procedure :: write => escan_data_write <>= module subroutine escan_data_write (data, unit, verbose) class(escan_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine escan_data_write <>= module subroutine escan_data_write (data, unit, verbose) class(escan_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i, j u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Energy-scan data:" write (u, "(3x,A)", advance="no") "prt_in = " do i = 1, 2 if (i > 1) write (u, "(',',1x)", advance="no") do j = 1, data%n_flv(i) if (j > 1) write (u, "(':')", advance="no") write (u, "(A)", advance="no") char (data%flv_in(j,i)%get_name ()) end do end do write (u, *) write (u, "(3x,A," // FMT_12 // ")") "norm =", data%norm end subroutine escan_data_write @ %def escan_data_write @ Kinematics is completely collinear, hence there is only one parameter for a pair spectrum. <>= procedure :: get_n_par => escan_data_get_n_par <>= module function escan_data_get_n_par (data) result (n) class(escan_data_t), intent(in) :: data integer :: n end function escan_data_get_n_par <>= module function escan_data_get_n_par (data) result (n) class(escan_data_t), intent(in) :: data integer :: n n = 1 end function escan_data_get_n_par @ %def escan_data_get_n_par @ Return the outgoing particles PDG codes. This is always the same as the incoming particle, where we use two indices for the two beams. <>= procedure :: get_pdg_out => escan_data_get_pdg_out <>= module subroutine escan_data_get_pdg_out (data, pdg_out) class(escan_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out end subroutine escan_data_get_pdg_out <>= module subroutine escan_data_get_pdg_out (data, pdg_out) class(escan_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n pdg_out(i) = data%flv_in(1:data%n_flv(i),i)%get_pdg () end do end subroutine escan_data_get_pdg_out @ %def escan_data_get_pdg_out @ Allocate the interaction record. Due to a gfortran 7/8/9 this has to remain in the main module. <>= procedure :: allocate_sf_int => escan_data_allocate_sf_int <>= subroutine escan_data_allocate_sf_int (data, sf_int) class(escan_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (escan_t :: sf_int) end subroutine escan_data_allocate_sf_int @ %def escan_data_allocate_sf_int @ \subsection{The Energy-scan object} This is a spectrum, not a radiation. We create an interaction with two incoming and two outgoing particles, flavor, color, and helicity being carried through. $x$ nevertheless is only one-dimensional, as we are always using only one beam parameter. <>= type, extends (sf_int_t) :: escan_t type(escan_data_t), pointer :: data => null () contains <> end type escan_t @ %def escan_t @ Type string: for the energy scan this is just a dummy function. <>= procedure :: type_string => escan_type_string <>= module function escan_type_string (object) result (string) class(escan_t), intent(in) :: object type(string_t) :: string end function escan_type_string <>= module function escan_type_string (object) result (string) class(escan_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "Escan: energy scan" else string = "Escan: [undefined]" end if end function escan_type_string @ %def escan_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => escan_write <>= module subroutine escan_write (object, unit, testflag) class(escan_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine escan_write <>= module subroutine escan_write (object, unit, testflag) class(escan_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "Energy scan data: [undefined]" end if end subroutine escan_write @ %def escan_write @ <>= procedure :: init => escan_init <>= module subroutine escan_init (sf_int, data) class(escan_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data end subroutine escan_init <>= module subroutine escan_init (sf_int, data) class(escan_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(4) :: mask integer, dimension(4) :: hel_lock real(default), dimension(2) :: m2 real(default), dimension(0) :: mr2 type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn type(polarization_t), target :: pol1, pol2 type(polarization_iterator_t) :: it_hel1, it_hel2 integer :: j1, j2 select type (data) type is (escan_data_t) hel_lock = [3, 4, 1, 2] m2 = data%flv_in(1,:)%get_mass () call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock) sf_int%data => data do j1 = 1, data%n_flv(1) call qn_fc(1)%init ( & flv = data%flv_in(j1,1), & col = color_from_flavor (data%flv_in(j1,1))) call qn_fc(3)%init ( & flv = data%flv_in(j1,1), & col = color_from_flavor (data%flv_in(j1,1))) call pol1%init_generic (data%flv_in(j1,1)) do j2 = 1, data%n_flv(2) call qn_fc(2)%init ( & flv = data%flv_in(j2,2), & col = color_from_flavor (data%flv_in(j2,2))) call qn_fc(4)%init ( & flv = data%flv_in(j2,2), & col = color_from_flavor (data%flv_in(j2,2))) call pol2%init_generic (data%flv_in(j2,2)) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel(1) = it_hel1%get_quantum_numbers () qn_hel(3) = it_hel1%get_quantum_numbers () call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel(2) = it_hel2%get_quantum_numbers () qn_hel(4) = it_hel2%get_quantum_numbers () qn = qn_hel .merge. qn_fc call sf_int%add_state (qn) call it_hel2%advance () end do call it_hel1%advance () end do ! call pol2%final () end do ! call pol1%final () end do call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) call sf_int%freeze () sf_int%status = SF_INITIAL end select end subroutine escan_init @ %def escan_init @ \subsection{Kinematics} Set kinematics. We have a single parameter, but reduce both beams. The [[map]] flag is ignored. <>= procedure :: complete_kinematics => escan_complete_kinematics <>= module subroutine escan_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(escan_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default) :: sqrt_x real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map end subroutine escan_complete_kinematics <>= module subroutine escan_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(escan_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default) :: sqrt_x real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map x = r xb= rb sqrt_x = sqrt (x(1)) if (sqrt_x > 0) then f = 1 / (2 * sqrt_x) else f = 0 sf_int%status = SF_FAILED_KINEMATICS return end if call sf_int%reduce_momenta ([sqrt_x, sqrt_x]) end subroutine escan_complete_kinematics @ %def escan_complete_kinematics @ Recover $x$. The base procedure should return two momentum fractions for the two beams, while we have only one parameter. This is the product of the extracted momentum fractions. <>= procedure :: recover_x => escan_recover_x <>= module subroutine escan_recover_x (sf_int, x, xb, x_free) class(escan_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free end subroutine escan_recover_x <>= module subroutine escan_recover_x (sf_int, x, xb, x_free) class(escan_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: xi, xib call sf_int%base_recover_x (xi, xib, x_free) x = product (xi) xb= 1 - x end subroutine escan_recover_x @ %def escan_recover_x @ Compute inverse kinematics. <>= procedure :: inverse_kinematics => escan_inverse_kinematics <>= module subroutine escan_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(escan_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta end subroutine escan_inverse_kinematics <>= module subroutine escan_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(escan_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default) :: sqrt_x logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta sqrt_x = sqrt (x(1)) if (sqrt_x > 0) then f = 1 / (2 * sqrt_x) else f = 0 sf_int%status = SF_FAILED_KINEMATICS return end if r = x rb = xb if (set_mom) then call sf_int%reduce_momenta ([sqrt_x, sqrt_x]) end if end subroutine escan_inverse_kinematics @ %def escan_inverse_kinematics @ \subsection{Energy scan application} Here, we insert the predefined norm. <>= procedure :: apply => escan_apply <>= module subroutine escan_apply (sf_int, scale, negative_sf, rescale, i_sub) class(escan_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub end subroutine escan_apply <>= module subroutine escan_apply (sf_int, scale, negative_sf, rescale, i_sub) class(escan_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: f associate (data => sf_int%data) f = data%norm end associate call sf_int%set_matrix_element (cmplx (f, kind=default)) sf_int%status = SF_EVALUATED end subroutine escan_apply @ %def escan_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_escan_ut.f90]]>>= <> module sf_escan_ut use unit_tests use sf_escan_uti <> <> contains <> end module sf_escan_ut @ %def sf_escan_ut @ <<[[sf_escan_uti.f90]]>>= <> module sf_escan_uti <> use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use sf_aux use sf_base use sf_escan <> <> contains <> end module sf_escan_uti @ %def sf_escan_ut @ API: driver for the unit tests below. <>= public :: sf_escan_test <>= subroutine sf_escan_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_escan_test @ %def sf_escan_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_escan_1, "sf_escan_1", & "structure function configuration", & u, results) <>= public :: sf_escan_1 <>= subroutine sf_escan_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_escan_1" write (u, "(A)") "* Purpose: initialize and display & &energy-scan structure function data" write (u, "(A)") call model%init_qed_test () pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON allocate (escan_data_t :: data) select type (data) type is (escan_data_t) call data%init (model, pdg_in, norm = 2._default) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_escan_1" end subroutine sf_escan_1 @ %def sf_escan_1 g@ \subsubsection{Probe the structure-function object} Active the beam event reader, generate an event. <>= call test (sf_escan_2, "sf_escan_2", & "generate event", & u, results) <>= public :: sf_escan_2 <>= subroutine sf_escan_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: x_free, f write (u, "(A)") "* Test output: sf_escan_2" write (u, "(A)") "* Purpose: initialize and display & &beam-events structure function data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (escan_data_t :: data) select type (data) type is (escan_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Set dummy parameters and generate x" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.8 rb = 1 - r x_free = 1 call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Inverse kinematics" write (u, "(A)") call sf_int%recover_x (x, xb, x_free) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_escan_2" end subroutine sf_escan_2 @ %def sf_escan_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Gaussian beam spread} Instead of an analytic beam description, beam data may be provided in form of an event file. In its most simple form, the event file contains pairs of $x$ values, relative to nominal beam energies. More advanced formats may include polarization, etc. The current implementation carries beam polarization through, if specified. The code is very similar to the energy scan described above. However, we must include a file-handle manager for the beam-event files. Two different processes may access a given beam-event file at the same time (i.e., serially but alternating). Accessing an open file from two different units is non-standard and not supported by all compilers. Therefore, we keep a global registry of open files, associated units, and reference counts. The [[gaussian_t]] objects act as proxies to this registry. <<[[sf_gaussian.f90]]>>= <> module sf_gaussian <> <> use rng_base use pdg_arrays use model_data use flavors use quantum_numbers use state_matrices use polarizations use sf_base <> <> <> interface <> end interface contains <> end module sf_gaussian @ %def sf_gaussian @ <<[[sf_gaussian_sub.f90]]>>= <> submodule (sf_gaussian) sf_gaussian_s use io_units use format_defs, only: FMT_12 use file_registries use diagnostics use lorentz implicit none contains <> end submodule sf_gaussian_s @ %def sf_gaussian_s @ \subsection{The beam-data file registry} We manage data files via the [[file_registries]] module. To this end, we keep the registry as a private module variable here. <>= type(file_registry_t), save :: beam_file_registry @ %def beam_file_registry @ \subsection{Data type} We store the spread for each beam, as a relative number related to the beam energy. For the actual generation, we include an (abstract) random-number generator factory. <>= public :: gaussian_data_t <>= type, extends(sf_data_t) :: gaussian_data_t private type(flavor_t), dimension(2) :: flv_in real(default), dimension(2) :: spread class(rng_factory_t), allocatable :: rng_factory contains <> end type gaussian_data_t @ %def gaussian_data_t <>= procedure :: init => gaussian_data_init <>= module subroutine gaussian_data_init & (data, model, pdg_in, spread, rng_factory) class(gaussian_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), dimension(2), intent(in) :: spread class(rng_factory_t), intent(inout), allocatable :: rng_factory end subroutine gaussian_data_init <>= module subroutine gaussian_data_init & (data, model, pdg_in, spread, rng_factory) class(gaussian_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), dimension(2), intent(in) :: spread class(rng_factory_t), intent(inout), allocatable :: rng_factory if (any (spread < 0)) then call msg_fatal ("Gaussian beam spread: must not be negative") end if call data%flv_in(1)%init (pdg_in(1)%get (1), model) call data%flv_in(2)%init (pdg_in(2)%get (1), model) data%spread = spread call move_alloc (from = rng_factory, to = data%rng_factory) end subroutine gaussian_data_init @ %def gaussian_data_init @ Return true since this spectrum is always in generator mode. <>= procedure :: is_generator => gaussian_data_is_generator <>= module function gaussian_data_is_generator (data) result (flag) class(gaussian_data_t), intent(in) :: data logical :: flag end function gaussian_data_is_generator <>= module function gaussian_data_is_generator (data) result (flag) class(gaussian_data_t), intent(in) :: data logical :: flag flag = .true. end function gaussian_data_is_generator @ %def gaussian_data_is_generator @ The number of parameters is two. They are free parameters. <>= procedure :: get_n_par => gaussian_data_get_n_par <>= module function gaussian_data_get_n_par (data) result (n) class(gaussian_data_t), intent(in) :: data integer :: n end function gaussian_data_get_n_par <>= module function gaussian_data_get_n_par (data) result (n) class(gaussian_data_t), intent(in) :: data integer :: n n = 2 end function gaussian_data_get_n_par @ %def gaussian_data_get_n_par <>= procedure :: get_pdg_out => gaussian_data_get_pdg_out <>= module subroutine gaussian_data_get_pdg_out (data, pdg_out) class(gaussian_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out end subroutine gaussian_data_get_pdg_out <>= module subroutine gaussian_data_get_pdg_out (data, pdg_out) class(gaussian_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n pdg_out(i) = data%flv_in(i)%get_pdg () end do end subroutine gaussian_data_get_pdg_out @ %def gaussian_data_get_pdg_out @ Allocate the interaction record. Due to a gfortran 7/8/9 bug has to remain in the main module. <>= procedure :: allocate_sf_int => gaussian_data_allocate_sf_int <>= subroutine gaussian_data_allocate_sf_int (data, sf_int) class(gaussian_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (gaussian_t :: sf_int) end subroutine gaussian_data_allocate_sf_int @ %def gaussian_data_allocate_sf_int @ Output <>= procedure :: write => gaussian_data_write <>= module subroutine gaussian_data_write (data, unit, verbose) class(gaussian_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine gaussian_data_write <>= module subroutine gaussian_data_write (data, unit, verbose) class(gaussian_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Gaussian beam spread data:" write (u, "(3x,A,A,A,A)") "prt_in = ", & char (data%flv_in(1)%get_name ()), & ", ", char (data%flv_in(2)%get_name ()) write (u, "(3x,A,2(1x," // FMT_12 // "))") "spread =", data%spread call data%rng_factory%write (u) end subroutine gaussian_data_write @ %def gaussian_data_write @ \subsection{The gaussian object} Flavor and polarization carried through, no radiated particles. The generator needs a random-number generator, obviously. <>= public :: gaussian_t <>= type, extends (sf_int_t) :: gaussian_t type(gaussian_data_t), pointer :: data => null () class(rng_t), allocatable :: rng contains <> end type gaussian_t @ %def gaussian_t @ Type string: show gaussian file. <>= procedure :: type_string => gaussian_type_string <>= module function gaussian_type_string (object) result (string) class(gaussian_t), intent(in) :: object type(string_t) :: string end function gaussian_type_string <>= module function gaussian_type_string (object) result (string) class(gaussian_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "Gaussian: gaussian beam-energy spread" else string = "Gaussian: [undefined]" end if end function gaussian_type_string @ %def gaussian_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => gaussian_write <>= module subroutine gaussian_write (object, unit, testflag) class(gaussian_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine gaussian_write <>= module subroutine gaussian_write (object, unit, testflag) class(gaussian_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%rng%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "gaussian data: [undefined]" end if end subroutine gaussian_write @ %def gaussian_write @ <>= procedure :: init => gaussian_init <>= module subroutine gaussian_init (sf_int, data) class(gaussian_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data end subroutine gaussian_init <>= module subroutine gaussian_init (sf_int, data) class(gaussian_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data real(default), dimension(2) :: m2 real(default), dimension(0) :: mr2 type(quantum_numbers_mask_t), dimension(4) :: mask integer, dimension(4) :: hel_lock type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn type(polarization_t), target :: pol1, pol2 type(polarization_iterator_t) :: it_hel1, it_hel2 integer :: i select type (data) type is (gaussian_data_t) m2 = data%flv_in%get_mass () ** 2 hel_lock = [3, 4, 1, 2] mask = quantum_numbers_mask (.false., .false., .false.) call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock) sf_int%data => data do i = 1, 2 call qn_fc(i)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i))) call qn_fc(i+2)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i))) end do call pol1%init_generic (data%flv_in(1)) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel(1) = it_hel1%get_quantum_numbers () qn_hel(3) = it_hel1%get_quantum_numbers () call pol2%init_generic (data%flv_in(2)) call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel(2) = it_hel2%get_quantum_numbers () qn_hel(4) = it_hel2%get_quantum_numbers () qn = qn_hel .merge. qn_fc call sf_int%add_state (qn) call it_hel2%advance () end do ! call pol2%final () call it_hel1%advance () end do ! call pol1%final () call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) sf_int%status = SF_INITIAL end select call sf_int%data%rng_factory%make (sf_int%rng) end subroutine gaussian_init @ %def gaussian_init @ This spectrum type needs a finalizer, which closes the data file. <>= procedure :: final => sf_gaussian_final <>= module subroutine sf_gaussian_final (object) class(gaussian_t), intent(inout) :: object end subroutine sf_gaussian_final <>= module subroutine sf_gaussian_final (object) class(gaussian_t), intent(inout) :: object call object%interaction_t%final () end subroutine sf_gaussian_final @ %def sf_gaussian_final @ \subsection{Kinematics} Refer to the [[data]] component. <>= procedure :: is_generator => gaussian_is_generator <>= module function gaussian_is_generator (sf_int) result (flag) class(gaussian_t), intent(in) :: sf_int logical :: flag end function gaussian_is_generator <>= module function gaussian_is_generator (sf_int) result (flag) class(gaussian_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function gaussian_is_generator @ %def gaussian_is_generator @ Generate free parameters. The $x$ value should be distributed with mean $1$ and $\sigma$ given by the spread. We reject negative $x$ values. (This cut slightly biases the distribution, but for reasonable (small) spreads negative $r$ should not occur. <>= procedure :: generate_free => gaussian_generate_free <>= module subroutine gaussian_generate_free (sf_int, r, rb, x_free) class(gaussian_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free end subroutine gaussian_generate_free <>= module subroutine gaussian_generate_free (sf_int, r, rb, x_free) class(gaussian_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free real(default), dimension(size(r)) :: z associate (data => sf_int%data) do call sf_int%rng%generate_gaussian (z) rb = z * data%spread r = 1 - rb x_free = x_free * product (r) if (all (r > 0)) exit end do end associate end subroutine gaussian_generate_free @ %def gaussian_generate_free @ Set kinematics. Trivial transfer since this is a pure generator. The [[map]] flag doesn't apply. <>= procedure :: complete_kinematics => gaussian_complete_kinematics <>= module subroutine gaussian_complete_kinematics & (sf_int, x, xb, f, r, rb, map) class(gaussian_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map end subroutine gaussian_complete_kinematics <>= module subroutine gaussian_complete_kinematics & (sf_int, x, xb, f, r, rb, map) class(gaussian_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("gaussian: map flag not supported") else x = r xb= rb f = 1 end if call sf_int%reduce_momenta (x) end subroutine gaussian_complete_kinematics @ %def gaussian_complete_kinematics @ Compute inverse kinematics. Trivial in this case. <>= procedure :: inverse_kinematics => gaussian_inverse_kinematics <>= module subroutine gaussian_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(gaussian_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta end subroutine gaussian_inverse_kinematics <>= module subroutine gaussian_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(gaussian_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("gaussian: map flag not supported") else r = x rb= xb f = 1 end if if (set_mom) then call sf_int%reduce_momenta (x) end if end subroutine gaussian_inverse_kinematics @ %def gaussian_inverse_kinematics @ \subsection{gaussian application} Trivial, just set the unit weight. <>= procedure :: apply => gaussian_apply <>= module subroutine gaussian_apply & (sf_int, scale, negative_sf, rescale, i_sub) class(gaussian_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub end subroutine gaussian_apply <>= module subroutine gaussian_apply & (sf_int, scale, negative_sf, rescale, i_sub) class(gaussian_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: f f = 1 call sf_int%set_matrix_element (cmplx (f, kind=default)) sf_int%status = SF_EVALUATED end subroutine gaussian_apply @ %def gaussian_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_gaussian_ut.f90]]>>= <> module sf_gaussian_ut use unit_tests use sf_gaussian_uti <> <> contains <> end module sf_gaussian_ut @ %def sf_gaussian_ut @ <<[[sf_gaussian_uti.f90]]>>= <> module sf_gaussian_uti <> use numeric_utils, only: pacify use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use rng_base use sf_aux use sf_base use sf_gaussian use rng_base_ut, only: rng_test_factory_t <> <> contains <> end module sf_gaussian_uti @ %def sf_gaussian_ut @ API: driver for the unit tests below. <>= public :: sf_gaussian_test <>= subroutine sf_gaussian_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_gaussian_test @ %def sf_gaussian_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_gaussian_1, "sf_gaussian_1", & "structure function configuration", & u, results) <>= public :: sf_gaussian_1 <>= subroutine sf_gaussian_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data class(rng_factory_t), allocatable :: rng_factory write (u, "(A)") "* Test output: sf_gaussian_1" write (u, "(A)") "* Purpose: initialize and display & &gaussian-spread structure function data" write (u, "(A)") call model%init_qed_test () pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON allocate (gaussian_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (gaussian_data_t) call data%init (model, pdg_in, [1e-2_default, 2e-2_default], rng_factory) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_gaussian_1" end subroutine sf_gaussian_1 @ %def sf_gaussian_1 @ \subsubsection{Probe the structure-function object} Active the beam event reader, generate an event. <>= call test (sf_gaussian_2, "sf_gaussian_2", & "generate event", & u, results) <>= public :: sf_gaussian_2 <>= subroutine sf_gaussian_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(rng_factory_t), allocatable :: rng_factory class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: x_free, f integer :: i write (u, "(A)") "* Test output: sf_gaussian_2" write (u, "(A)") "* Purpose: initialize and display & &gaussian-spread structure function data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (gaussian_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (gaussian_data_t) call data%init (model, pdg_in, [1e-2_default, 2e-2_default], rng_factory) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Set dummy parameters and generate x." write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call pacify (rb, 1.e-8_default) call pacify (xb, 1.e-8_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Generate more events" write (u, "(A)") select type (sf_int) type is (gaussian_t) do i = 1, 3 call sf_int%generate_free (r, rb, x_free) write (u, "(A,9(1x,F10.7))") "r =", r end do end select write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_gaussian_2" end subroutine sf_gaussian_2 @ %def sf_gaussian_2 @ \clearpage @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Using beam event data} Instead of an analytic beam description, beam data may be provided in form of an event file. In its most simple form, the event file contains pairs of $x$ values, relative to nominal beam energies. More advanced formats may include polarization, etc. The current implementation carries beam polarization through, if specified. The code is very similar to the energy scan described above. However, we must include a file-handle manager for the beam-event files. Two different processes may access a given beam-event file at the same time (i.e., serially but alternating). Accessing an open file from two different units is non-standard and not supported by all compilers. Therefore, we keep a global registry of open files, associated units, and reference counts. The [[beam_events_t]] objects act as proxies to this registry. <<[[sf_beam_events.f90]]>>= <> module sf_beam_events <> <> use file_registries use pdg_arrays use model_data use flavors use quantum_numbers use state_matrices use polarizations use sf_base <> <> <> <> interface <> end interface contains <> end module sf_beam_events @ %def sf_beam_events @ <<[[sf_beam_events_sub.f90]]>>= <> submodule (sf_beam_events) sf_beam_events_s use io_units use diagnostics use lorentz implicit none contains <> end submodule sf_beam_events_s @ %def sf_beam_events_s @ \subsection{The beam-data file registry} We manage data files via the [[file_registries]] module. To this end, we keep the registry as a private module variable here. This is public only for the unit tests. <>= public :: beam_file_registry <>= type(file_registry_t), save :: beam_file_registry @ %def beam_file_registry @ \subsection{Data type} <>= public :: beam_events_data_t <>= type, extends(sf_data_t) :: beam_events_data_t private type(flavor_t), dimension(2) :: flv_in type(string_t) :: dir type(string_t) :: file type(string_t) :: fqn integer :: unit = 0 logical :: warn_eof = .true. contains <> end type beam_events_data_t @ %def beam_events_data_t <>= procedure :: init => beam_events_data_init <>= module subroutine beam_events_data_init & (data, model, pdg_in, dir, file, warn_eof) class(beam_events_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in type(string_t), intent(in) :: dir type(string_t), intent(in) :: file logical, intent(in), optional :: warn_eof end subroutine beam_events_data_init <>= module subroutine beam_events_data_init & (data, model, pdg_in, dir, file, warn_eof) class(beam_events_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in type(string_t), intent(in) :: dir type(string_t), intent(in) :: file logical, intent(in), optional :: warn_eof if (any (pdg_in%get_length () /= 1)) then call msg_fatal ("Beam events: incoming beam particles must be unique") end if call data%flv_in(1)%init (pdg_in(1)%get (1), model) call data%flv_in(2)%init (pdg_in(2)%get (1), model) data%dir = dir data%file = file if (present (warn_eof)) data%warn_eof = warn_eof end subroutine beam_events_data_init @ %def beam_events_data_init @ Return true since this spectrum is always in generator mode. <>= procedure :: is_generator => beam_events_data_is_generator <>= module function beam_events_data_is_generator (data) result (flag) class(beam_events_data_t), intent(in) :: data logical :: flag end function beam_events_data_is_generator <>= module function beam_events_data_is_generator (data) result (flag) class(beam_events_data_t), intent(in) :: data logical :: flag flag = .true. end function beam_events_data_is_generator @ %def beam_events_data_is_generator @ The number of parameters is two. They are free parameters. <>= procedure :: get_n_par => beam_events_data_get_n_par <>= module function beam_events_data_get_n_par (data) result (n) class(beam_events_data_t), intent(in) :: data integer :: n end function beam_events_data_get_n_par <>= module function beam_events_data_get_n_par (data) result (n) class(beam_events_data_t), intent(in) :: data integer :: n n = 2 end function beam_events_data_get_n_par @ %def beam_events_data_get_n_par <>= procedure :: get_pdg_out => beam_events_data_get_pdg_out <>= module subroutine beam_events_data_get_pdg_out (data, pdg_out) class(beam_events_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out end subroutine beam_events_data_get_pdg_out <>= module subroutine beam_events_data_get_pdg_out (data, pdg_out) class(beam_events_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n pdg_out(i) = data%flv_in(i)%get_pdg () end do end subroutine beam_events_data_get_pdg_out @ %def beam_events_data_get_pdg_out @ Allocate the interaction record. Due to a gfortran 7/8/9 bug has to remain in the main module. <>= procedure :: allocate_sf_int => beam_events_data_allocate_sf_int <>= subroutine beam_events_data_allocate_sf_int (data, sf_int) class(beam_events_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (beam_events_t :: sf_int) end subroutine beam_events_data_allocate_sf_int @ %def beam_events_data_allocate_sf_int @ Output <>= procedure :: write => beam_events_data_write <>= module subroutine beam_events_data_write (data, unit, verbose) class(beam_events_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine beam_events_data_write <>= module subroutine beam_events_data_write (data, unit, verbose) class(beam_events_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Beam-event file data:" write (u, "(3x,A,A,A,A)") "prt_in = ", & char (data%flv_in(1)%get_name ()), & ", ", char (data%flv_in(2)%get_name ()) write (u, "(3x,A,A,A)") "file = '", char (data%file), "'" write (u, "(3x,A,I0)") "unit = ", data%unit write (u, "(3x,A,L1)") "warn = ", data%warn_eof end subroutine beam_events_data_write @ %def beam_events_data_write @ The data file needs to be opened and closed explicitly. The open/close message is communicated to the file handle registry, which does the actual work. We determine first whether to look in the local directory or in the given system directory. <>= procedure :: open => beam_events_data_open procedure :: close => beam_events_data_close <>= module subroutine beam_events_data_open (data) class(beam_events_data_t), intent(inout) :: data end subroutine beam_events_data_open module subroutine beam_events_data_close (data) class(beam_events_data_t), intent(inout) :: data end subroutine beam_events_data_close <>= module subroutine beam_events_data_open (data) class(beam_events_data_t), intent(inout) :: data logical :: exist if (data%unit == 0) then data%fqn = data%file if (data%fqn == "") & call msg_fatal ("Beam events: $beam_events_file is not set") inquire (file = char (data%fqn), exist = exist) if (.not. exist) then data%fqn = data%dir // "/" // data%file inquire (file = char (data%fqn), exist = exist) if (.not. exist) then data%fqn = "" call msg_fatal ("Beam events: file '" & // char (data%file) // "' not found") return end if end if call msg_message ("Beam events: reading from file '" & // char (data%file) // "'") call beam_file_registry%open (data%fqn, data%unit) else call msg_bug ("Beam events: file '" & // char (data%file) // "' is already open") end if end subroutine beam_events_data_open module subroutine beam_events_data_close (data) class(beam_events_data_t), intent(inout) :: data if (data%unit /= 0) then call beam_file_registry%close (data%fqn) call msg_message ("Beam events: closed file '" & // char (data%file) // "'") data%unit = 0 end if end subroutine beam_events_data_close @ %def beam_events_data_close @ Return the beam event file. <>= procedure :: get_beam_file => beam_events_data_get_beam_file <>= module function beam_events_data_get_beam_file (data) result (file) class(beam_events_data_t), intent(in) :: data type(string_t) :: file end function beam_events_data_get_beam_file <>= module function beam_events_data_get_beam_file (data) result (file) class(beam_events_data_t), intent(in) :: data type(string_t) :: file file = "Beam events: " // data%file end function beam_events_data_get_beam_file @ %def beam_events_data_get_beam_file @ \subsection{The beam events object} Flavor and polarization carried through, no radiated particles. <>= public :: beam_events_t <>= type, extends (sf_int_t) :: beam_events_t type(beam_events_data_t), pointer :: data => null () integer :: count = 0 contains <> end type beam_events_t @ %def beam_events_t @ Type string: show beam events file. <>= procedure :: type_string => beam_events_type_string <>= module function beam_events_type_string (object) result (string) class(beam_events_t), intent(in) :: object type(string_t) :: string end function beam_events_type_string <>= module function beam_events_type_string (object) result (string) class(beam_events_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "Beam events: " // object%data%file else string = "Beam events: [undefined]" end if end function beam_events_type_string @ %def beam_events_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => beam_events_write <>= module subroutine beam_events_write (object, unit, testflag) class(beam_events_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine beam_events_write <>= module subroutine beam_events_write (object, unit, testflag) class(beam_events_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "Beam events data: [undefined]" end if end subroutine beam_events_write @ %def beam_events_write @ <>= procedure :: init => beam_events_init <>= module subroutine beam_events_init (sf_int, data) class(beam_events_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data end subroutine beam_events_init <>= module subroutine beam_events_init (sf_int, data) class(beam_events_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data real(default), dimension(2) :: m2 real(default), dimension(0) :: mr2 type(quantum_numbers_mask_t), dimension(4) :: mask integer, dimension(4) :: hel_lock type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn type(polarization_t), target :: pol1, pol2 type(polarization_iterator_t) :: it_hel1, it_hel2 integer :: i select type (data) type is (beam_events_data_t) m2 = data%flv_in%get_mass () ** 2 hel_lock = [3, 4, 1, 2] mask = quantum_numbers_mask (.false., .false., .false.) call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock) sf_int%data => data do i = 1, 2 call qn_fc(i)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i))) call qn_fc(i+2)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i))) end do call pol1%init_generic (data%flv_in(1)) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel(1) = it_hel1%get_quantum_numbers () qn_hel(3) = it_hel1%get_quantum_numbers () call pol2%init_generic (data%flv_in(2)) call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel(2) = it_hel2%get_quantum_numbers () qn_hel(4) = it_hel2%get_quantum_numbers () qn = qn_hel .merge. qn_fc call sf_int%add_state (qn) call it_hel2%advance () end do ! call pol2%final () call it_hel1%advance () end do ! call pol1%final () call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) call sf_int%data%open () sf_int%status = SF_INITIAL end select end subroutine beam_events_init @ %def beam_events_init @ This spectrum type needs a finalizer, which closes the data file. <>= procedure :: final => sf_beam_events_final <>= module subroutine sf_beam_events_final (object) class(beam_events_t), intent(inout) :: object end subroutine sf_beam_events_final <>= module subroutine sf_beam_events_final (object) class(beam_events_t), intent(inout) :: object call object%data%close () call object%interaction_t%final () end subroutine sf_beam_events_final @ %def sf_beam_events_final @ \subsection{Kinematics} Refer to the [[data]] component. <>= procedure :: is_generator => beam_events_is_generator <>= module function beam_events_is_generator (sf_int) result (flag) class(beam_events_t), intent(in) :: sf_int logical :: flag end function beam_events_is_generator <>= module function beam_events_is_generator (sf_int) result (flag) class(beam_events_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function beam_events_is_generator @ %def beam_events_is_generator @ Generate free parameters. We read them from file. <>= procedure :: generate_free => beam_events_generate_free <>= recursive module subroutine beam_events_generate_free & (sf_int, r, rb, x_free) class(beam_events_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free end subroutine beam_events_generate_free <>= recursive module subroutine beam_events_generate_free & (sf_int, r, rb, x_free) class(beam_events_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free integer :: iostat associate (data => sf_int%data) if (data%unit /= 0) then read (data%unit, fmt=*, iostat=iostat) r if (iostat > 0) then write (msg_buffer, "(A,I0,A)") & "Beam events: I/O error after reading ", sf_int%count, & " events" call msg_fatal () else if (iostat < 0) then if (sf_int%count == 0) then call msg_fatal ("Beam events: file is empty") else if (sf_int%data%warn_eof) then write (msg_buffer, "(A,I0,A)") & "Beam events: End of file after reading ", sf_int%count, & " events, rewinding" call msg_warning () end if rewind (data%unit) sf_int%count = 0 call sf_int%generate_free (r, rb, x_free) else sf_int%count = sf_int%count + 1 rb = 1 - r x_free = x_free * product (r) end if else call msg_bug ("Beam events: file is not open for reading") end if end associate end subroutine beam_events_generate_free @ %def beam_events_generate_free @ Set kinematics. Trivial transfer since this is a pure generator. The [[map]] flag doesn't apply. <>= procedure :: complete_kinematics => beam_events_complete_kinematics <>= module subroutine beam_events_complete_kinematics & (sf_int, x, xb, f, r, rb, map) class(beam_events_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map end subroutine beam_events_complete_kinematics <>= module subroutine beam_events_complete_kinematics & (sf_int, x, xb, f, r, rb, map) class(beam_events_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("Beam events: map flag not supported") else x = r xb= rb f = 1 end if call sf_int%reduce_momenta (x) end subroutine beam_events_complete_kinematics @ %def beam_events_complete_kinematics @ Compute inverse kinematics. Trivial in this case. <>= procedure :: inverse_kinematics => beam_events_inverse_kinematics <>= module subroutine beam_events_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(beam_events_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta end subroutine beam_events_inverse_kinematics <>= module subroutine beam_events_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(beam_events_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("Beam events: map flag not supported") else r = x rb= xb f = 1 end if if (set_mom) then call sf_int%reduce_momenta (x) end if end subroutine beam_events_inverse_kinematics @ %def beam_events_inverse_kinematics @ \subsection{Beam events application} Trivial, just set the unit weight. <>= procedure :: apply => beam_events_apply <>= module subroutine beam_events_apply & (sf_int, scale, negative_sf, rescale, i_sub) class(beam_events_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub end subroutine beam_events_apply <>= module subroutine beam_events_apply & (sf_int, scale, negative_sf, rescale, i_sub) class(beam_events_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: f f = 1 call sf_int%set_matrix_element (cmplx (f, kind=default)) sf_int%status = SF_EVALUATED end subroutine beam_events_apply @ %def beam_events_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_beam_events_ut.f90]]>>= <> module sf_beam_events_ut use unit_tests use sf_beam_events_uti <> <> contains <> end module sf_beam_events_ut @ %def sf_beam_events_ut @ <<[[sf_beam_events_uti.f90]]>>= <> module sf_beam_events_uti <> <> use io_units use numeric_utils, only: pacify use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use sf_aux use sf_base use sf_beam_events <> <> contains <> end module sf_beam_events_uti @ %def sf_beam_events_ut @ API: driver for the unit tests below. <>= public :: sf_beam_events_test <>= subroutine sf_beam_events_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_beam_events_test @ %def sf_beam_events_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_beam_events_1, "sf_beam_events_1", & "structure function configuration", & u, results) <>= public :: sf_beam_events_1 <>= subroutine sf_beam_events_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_beam_events_1" write (u, "(A)") "* Purpose: initialize and display & &beam-events structure function data" write (u, "(A)") call model%init_qed_test () pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON allocate (beam_events_data_t :: data) select type (data) type is (beam_events_data_t) call data%init (model, pdg_in, var_str (""), var_str ("beam_events.dat")) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_beam_events_1" end subroutine sf_beam_events_1 @ %def sf_beam_events_1 @ \subsubsection{Probe the structure-function object} Active the beam event reader, generate an event. <>= call test (sf_beam_events_2, "sf_beam_events_2", & "generate event", & u, results) <>= public :: sf_beam_events_2 <>= subroutine sf_beam_events_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: x_free, f integer :: i write (u, "(A)") "* Test output: sf_beam_events_2" write (u, "(A)") "* Purpose: initialize and display & &beam-events structure function data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (beam_events_data_t :: data) select type (data) type is (beam_events_data_t) call data%init (model, pdg_in, & var_str (""), var_str ("test_beam_events.dat")) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Set dummy parameters and generate x." write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free select type (sf_int) type is (beam_events_t) write (u, "(A,1x,I0)") "count =", sf_int%count end select write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Generate more events, rewind" write (u, "(A)") select type (sf_int) type is (beam_events_t) do i = 1, 3 call sf_int%generate_free (r, rb, x_free) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,1x,I0)") "count =", sf_int%count end do end select write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_beam_events_2" end subroutine sf_beam_events_2 @ %def sf_beam_events_2 @ \subsubsection{Check the file handle registry} Open and close some files, checking the registry contents. <>= call test (sf_beam_events_3, "sf_beam_events_3", & "check registry", & u, results) <>= public :: sf_beam_events_3 <>= subroutine sf_beam_events_3 (u) integer, intent(in) :: u integer :: u1 write (u, "(A)") "* Test output: sf_beam_events_2" write (u, "(A)") "* Purpose: check file handle registry" write (u, "(A)") write (u, "(A)") "* Create some empty files" write (u, "(A)") u1 = free_unit () open (u1, file = "sf_beam_events_f1.tmp", action="write", status="new") close (u1) open (u1, file = "sf_beam_events_f2.tmp", action="write", status="new") close (u1) open (u1, file = "sf_beam_events_f3.tmp", action="write", status="new") close (u1) write (u, "(A)") "* Empty registry" write (u, "(A)") call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Insert three entries" write (u, "(A)") call beam_file_registry%open (var_str ("sf_beam_events_f3.tmp")) call beam_file_registry%open (var_str ("sf_beam_events_f2.tmp")) call beam_file_registry%open (var_str ("sf_beam_events_f1.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Open a second channel" write (u, "(A)") call beam_file_registry%open (var_str ("sf_beam_events_f2.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Close second entry twice" write (u, "(A)") call beam_file_registry%close (var_str ("sf_beam_events_f2.tmp")) call beam_file_registry%close (var_str ("sf_beam_events_f2.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Close last entry" write (u, "(A)") call beam_file_registry%close (var_str ("sf_beam_events_f3.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Close remaining entry" write (u, "(A)") call beam_file_registry%close (var_str ("sf_beam_events_f1.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" open (u1, file = "sf_beam_events_f1.tmp", action="write") close (u1, status = "delete") open (u1, file = "sf_beam_events_f2.tmp", action="write") close (u1, status = "delete") open (u1, file = "sf_beam_events_f3.tmp", action="write") close (u1, status = "delete") write (u, "(A)") write (u, "(A)") "* Test output end: sf_beam_events_3" end subroutine sf_beam_events_3 @ %def sf_beam_events_3 @ \clearpage %------------------------------------------------------------------------ \section{Lepton collider beamstrahlung: CIRCE1} <<[[sf_circe1.f90]]>>= <> module sf_circe1 <> use kinds, only: double <> use rng_base use pdg_arrays use model_data use flavors use polarizations use sf_mappings use sf_base use circe1, circe1_rng_t => rng_type !NODEP! <> <> <> interface <> end interface contains <> end module sf_circe1 @ %def sf_circe1 @ <<[[sf_circe1_sub.f90]]>>= <> submodule (sf_circe1) sf_circe1_s use io_units use format_defs, only: FMT_17, FMT_19 use diagnostics use physics_defs, only: ELECTRON, PHOTON use lorentz use colors use quantum_numbers use state_matrices implicit none contains <> end submodule sf_circe1_s @ %def sf_circe1_s @ \subsection{Physics} Beamstrahlung is applied before ISR. The [[CIRCE1]] implementation has a single structure function for both beams (which makes sense since it has to be switched on or off for both beams simultaneously). Nevertheless it is factorized: The functional form in the [[CIRCE1]] parameterization is defined for electrons or photons \begin{equation} f(x) = \alpha\,x^\beta\,(1-x)^\gamma \end{equation} for $x<1-\epsilon$ (resp.\ $x>\epsilon$ in the photon case). In the remaining interval, the standard form is zero, with a delta singularity at $x=1$ (resp.\ $x=0$). Equivalently, the delta part may be distributed uniformly among this interval. This latter form is implemented in the [[kirke]] version of the [[CIRCE1]] subroutines, and is used here. The parameter [[circe1\_eps]] sets the peak mapping of the [[CIRCE1]] structure function. Its default value is $10^{-5}$. The other parameters are the parameterization version and revision number, the accelerator type, and the $\sqrt{s}$ value used by [[CIRCE1]]. The chattiness can also be set. Since the energy is distributed in a narrow region around unity (for electrons) or zero (for photons), it is advantageous to map the interval first. The mapping is controlled by the parameter [[circe1\_epsilon]] which is taken from the [[CIRCE1]] internal data structure. The $\sqrt{s}$ value, if not explicitly set, is taken from the process data. Note that interpolating $\sqrt{s}$ is not recommended; one should rather choose one of the distinct values known to [[CIRCE1]]. \subsection{The CIRCE1 data block} The CIRCE1 parameters are: The incoming flavors, the flags whether the photon or the lepton is the parton in the hard interaction, the flags for the generation mode (generator/mapping/no mapping), the mapping parameter $\epsilon$, $\sqrt{s}$ and several steering parameters: [[ver]], [[rev]], [[acc]], [[chat]]. In generator mode, the $x$ values are actually discarded and a random number generator is used instead. <>= public :: circe1_data_t <>= type, extends (sf_data_t) :: circe1_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(2) :: flv_in integer, dimension(2) :: pdg_in real(default), dimension(2) :: m_in = 0 logical, dimension(2) :: photon = .false. logical :: generate = .false. class(rng_factory_t), allocatable :: rng_factory real(default) :: sqrts = 0 real(default) :: eps = 0 integer :: ver = 0 integer :: rev = 0 character(6) :: acc = "?" integer :: chat = 0 logical :: with_radiation = .false. contains <> end type circe1_data_t @ %def circe1_data_t @ <>= procedure :: init => circe1_data_init <>= module subroutine circe1_data_init & (data, model, pdg_in, sqrts, eps, out_photon, & ver, rev, acc, chat, with_radiation) class(circe1_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), intent(in) :: sqrts real(default), intent(in) :: eps logical, dimension(2), intent(in) :: out_photon character(*), intent(in) :: acc integer, intent(in) :: ver, rev, chat logical, intent(in) :: with_radiation end subroutine circe1_data_init <>= module subroutine circe1_data_init & (data, model, pdg_in, sqrts, eps, out_photon, & ver, rev, acc, chat, with_radiation) class(circe1_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), intent(in) :: sqrts real(default), intent(in) :: eps logical, dimension(2), intent(in) :: out_photon character(*), intent(in) :: acc integer, intent(in) :: ver, rev, chat logical, intent(in) :: with_radiation data%model => model if (any (pdg_in%get_length () /= 1)) then call msg_fatal ("CIRCE1: incoming beam particles must be unique") end if call data%flv_in(1)%init (pdg_in(1)%get (1), model) call data%flv_in(2)%init (pdg_in(2)%get (1), model) data%pdg_in = data%flv_in%get_pdg () data%m_in = data%flv_in%get_mass () data%sqrts = sqrts data%eps = eps data%photon = out_photon data%ver = ver data%rev = rev data%acc = acc data%chat = chat data%with_radiation = with_radiation call data%check () call circex (0.d0, 0.d0, dble (data%sqrts), & data%acc, data%ver, data%rev, data%chat) end subroutine circe1_data_init @ %def circe1_data_init @ Activate the generator mode. We import a RNG factory into the data type, which can then spawn RNG generator objects. <>= procedure :: set_generator_mode => circe1_data_set_generator_mode <>= module subroutine circe1_data_set_generator_mode (data, rng_factory) class(circe1_data_t), intent(inout) :: data class(rng_factory_t), intent(inout), allocatable :: rng_factory end subroutine circe1_data_set_generator_mode <>= module subroutine circe1_data_set_generator_mode (data, rng_factory) class(circe1_data_t), intent(inout) :: data class(rng_factory_t), intent(inout), allocatable :: rng_factory data%generate = .true. call move_alloc (from = rng_factory, to = data%rng_factory) end subroutine circe1_data_set_generator_mode @ %def circe1_data_set_generator_mode @ Handle error conditions. <>= procedure :: check => circe1_data_check <>= module subroutine circe1_data_check (data) class(circe1_data_t), intent(in) :: data end subroutine circe1_data_check <>= module subroutine circe1_data_check (data) class(circe1_data_t), intent(in) :: data type(flavor_t) :: flv_electron, flv_photon call flv_electron%init (ELECTRON, data%model) call flv_photon%init (PHOTON, data%model) if (.not. flv_electron%is_defined () & .or. .not. flv_photon%is_defined ()) then call msg_fatal ("CIRCE1: model must contain photon and electron") end if if (any (abs (data%pdg_in) /= ELECTRON) & .or. (data%pdg_in(1) /= - data%pdg_in(2))) then call msg_fatal ("CIRCE1: applicable only for e+e- or e-e+ collisions") end if if (data%eps <= 0) then call msg_error ("CIRCE1: circe1_eps = 0: integration will & &miss x=1 peak") end if end subroutine circe1_data_check @ %def circe1_data_check @ Output <>= procedure :: write => circe1_data_write <>= module subroutine circe1_data_write (data, unit, verbose) class(circe1_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine circe1_data_write <>= module subroutine circe1_data_write (data, unit, verbose) class(circe1_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u logical :: verb verb = .false.; if (present (verbose)) verb = verbose u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "CIRCE1 data:" write (u, "(3x,A,2(1x,A))") "prt_in =", & char (data%flv_in(1)%get_name ()), & char (data%flv_in(2)%get_name ()) write (u, "(3x,A,2(1x,L1))") "photon =", data%photon write (u, "(3x,A,L1)") "generate = ", data%generate write (u, "(3x,A,2(1x," // FMT_19 // "))") "m_in =", data%m_in write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", data%sqrts write (u, "(3x,A," // FMT_19 // ")") "eps = ", data%eps write (u, "(3x,A,I0)") "ver = ", data%ver write (u, "(3x,A,I0)") "rev = ", data%rev write (u, "(3x,A,A)") "acc = ", data%acc write (u, "(3x,A,I0)") "chat = ", data%chat write (u, "(3x,A,L1)") "with rad.= ", data%with_radiation if (data%generate) then if (verb) then call data%rng_factory%write (u) end if end if end subroutine circe1_data_write @ %def circe1_data_write @ Return true if this structure function is in generator mode. In that case, all parameters are free, otherwise bound. (We do not support mixed cases.) Default is: no generator. <>= procedure :: is_generator => circe1_data_is_generator <>= module function circe1_data_is_generator (data) result (flag) class(circe1_data_t), intent(in) :: data logical :: flag end function circe1_data_is_generator <>= module function circe1_data_is_generator (data) result (flag) class(circe1_data_t), intent(in) :: data logical :: flag flag = data%generate end function circe1_data_is_generator @ %def circe1_data_is_generator @ The number of parameters is two, collinear splitting for the two beams. <>= procedure :: get_n_par => circe1_data_get_n_par <>= module function circe1_data_get_n_par (data) result (n) class(circe1_data_t), intent(in) :: data integer :: n end function circe1_data_get_n_par <>= module function circe1_data_get_n_par (data) result (n) class(circe1_data_t), intent(in) :: data integer :: n n = 2 end function circe1_data_get_n_par @ %def circe1_data_get_n_par @ Return the outgoing particles PDG codes. This is either the incoming particle (if a photon is radiated), or the photon if that is the particle of the hard interaction. The latter is determined via the [[photon]] flag. There are two entries for the two beams. <>= procedure :: get_pdg_out => circe1_data_get_pdg_out <>= module subroutine circe1_data_get_pdg_out (data, pdg_out) class(circe1_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out end subroutine circe1_data_get_pdg_out <>= module subroutine circe1_data_get_pdg_out (data, pdg_out) class(circe1_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n if (data%photon(i)) then pdg_out(i) = PHOTON else pdg_out(i) = data%pdg_in(i) end if end do end subroutine circe1_data_get_pdg_out @ %def circe1_data_get_pdg_out @ This variant is not inherited, it returns integers. <>= procedure :: get_pdg_int => circe1_data_get_pdg_int <>= module function circe1_data_get_pdg_int (data) result (pdg) class(circe1_data_t), intent(in) :: data integer, dimension(2) :: pdg end function circe1_data_get_pdg_int <>= module function circe1_data_get_pdg_int (data) result (pdg) class(circe1_data_t), intent(in) :: data integer, dimension(2) :: pdg integer :: i do i = 1, 2 if (data%photon(i)) then pdg(i) = PHOTON else pdg(i) = data%pdg_in(i) end if end do end function circe1_data_get_pdg_int @ %def circe1_data_get_pdg_int @ Allocate the interaction record. Due to the gfortran 7/8/9 bug this has to remain in the main module. <>= procedure :: allocate_sf_int => circe1_data_allocate_sf_int <>= subroutine circe1_data_allocate_sf_int (data, sf_int) class(circe1_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (circe1_t :: sf_int) end subroutine circe1_data_allocate_sf_int @ %def circe1_data_allocate_sf_int @ Return the accelerator type. <>= procedure :: get_beam_file => circe1_data_get_beam_file <>= module function circe1_data_get_beam_file (data) result (file) class(circe1_data_t), intent(in) :: data type(string_t) :: file end function circe1_data_get_beam_file <>= module function circe1_data_get_beam_file (data) result (file) class(circe1_data_t), intent(in) :: data type(string_t) :: file file = "CIRCE1: " // data%acc end function circe1_data_get_beam_file @ %def circe1_data_get_beam_file @ \subsection{Random Number Generator for CIRCE} The CIRCE implementation now supports a generic random-number generator object that allows for a local state as a component. To support this, we must extend the abstract type provided by CIRCE and delegate the generator call to the (also abstract) RNG used by WHIZARD. <>= type, extends (circe1_rng_t) :: rng_obj_t class(rng_t), allocatable :: rng contains procedure :: generate => rng_obj_generate end type rng_obj_t @ %def rng_obj_t <>= module subroutine rng_obj_generate (rng_obj, u) class(rng_obj_t), intent(inout) :: rng_obj real(double), intent(out) :: u end subroutine rng_obj_generate <>= module subroutine rng_obj_generate (rng_obj, u) class(rng_obj_t), intent(inout) :: rng_obj real(double), intent(out) :: u real(default) :: x call rng_obj%rng%generate (x) u = x end subroutine rng_obj_generate @ %def rng_obj_generate @ \subsection{The CIRCE1 object} This is a $2\to 4$ interaction, where, depending on the parameters, any two of the four outgoing particles are connected to the hard interactions, the others are radiated. Knowing that all particles are colorless, we do not have to deal with color. The flavors are sorted such that the first two particles are the incoming leptons, the next two are the radiated particles, and the last two are the partons initiating the hard interaction. CIRCE1 does not support polarized beams explicitly. For simplicity, we nevertheless carry beam polarization through to the outgoing electrons and make the photons unpolarized. In the case that no radiated particle is kept (which actually is the default), polarization is always transferred to the electrons, too. If there is a recoil photon in the event, the radiated particles are 3 and 4, respectively, and 5 and 6 are the outgoing ones (triggering the hard scattering process), while in the case of no radiation, the outgoing particles are 3 and 4, respectively. In the case of the electron being the radiated particle, helicity is not kept. <>= public :: circe1_t <>= type, extends (sf_int_t) :: circe1_t type(circe1_data_t), pointer :: data => null () real(default), dimension(2) :: x = 0 real(default), dimension(2) :: xb= 0 real(default) :: f = 0 logical, dimension(2) :: continuum = .true. logical, dimension(2) :: peak = .true. type(rng_obj_t) :: rng_obj contains <> end type circe1_t @ %def circe1_t @ Type string: has to be here, but there is no string variable on which CIRCE1 depends. Hence, a dummy routine. <>= procedure :: type_string => circe1_type_string <>= module function circe1_type_string (object) result (string) class(circe1_t), intent(in) :: object type(string_t) :: string end function circe1_type_string <>= module function circe1_type_string (object) result (string) class(circe1_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "CIRCE1: beamstrahlung" else string = "CIRCE1: [undefined]" end if end function circe1_type_string @ %def circe1_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => circe1_write <>= module subroutine circe1_write (object, unit, testflag) class(circe1_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine circe1_write <>= module subroutine circe1_write (object, unit, testflag) class(circe1_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%data%generate) call object%rng_obj%rng%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(3x,A,2(1x," // FMT_17 // "))") "x =", object%x write (u, "(3x,A,2(1x," // FMT_17 // "))") "xb=", object%xb if (object%status >= SF_FAILED_EVALUATION) then write (u, "(3x,A,1x," // FMT_17 // ")") "f =", object%f end if end if call object%base_write (u, testflag) else write (u, "(1x,A)") "CIRCE1 data: [undefined]" end if end subroutine circe1_write @ %def circe1_write @ <>= procedure :: init => circe1_init <>= module subroutine circe1_init (sf_int, data) class(circe1_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data end subroutine circe1_init <>= module subroutine circe1_init (sf_int, data) class(circe1_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data logical, dimension(6) :: mask_h type(quantum_numbers_mask_t), dimension(6) :: mask integer, dimension(6) :: hel_lock type(polarization_t), target :: pol1, pol2 type(quantum_numbers_t), dimension(1) :: qn_fc1, qn_fc2 type(flavor_t) :: flv_photon type(color_t) :: col0 real(default), dimension(2) :: mi2, mr2, mo2 type(quantum_numbers_t) :: qn_hel1, qn_hel2, qn_photon, qn1, qn2 type(quantum_numbers_t), dimension(6) :: qn type(polarization_iterator_t) :: it_hel1, it_hel2 hel_lock = 0 mask_h = .false. select type (data) type is (circe1_data_t) mi2 = data%m_in**2 if (data%with_radiation) then if (data%photon(1)) then hel_lock(1) = 3; hel_lock(3) = 1; mask_h(5) = .true. mr2(1) = mi2(1) mo2(1) = 0._default else hel_lock(1) = 5; hel_lock(5) = 1; mask_h(3) = .true. mr2(1) = 0._default mo2(1) = mi2(1) end if if (data%photon(2)) then hel_lock(2) = 4; hel_lock(4) = 2; mask_h(6) = .true. mr2(2) = mi2(2) mo2(2) = 0._default else hel_lock(2) = 6; hel_lock(6) = 2; mask_h(4) = .true. mr2(2) = 0._default mo2(2) = mi2(2) end if mask = quantum_numbers_mask (.false., .false., mask_h) call sf_int%base_init (mask, mi2, mr2, mo2, & hel_lock = hel_lock) sf_int%data => data call flv_photon%init (PHOTON, data%model) call col0%init () call qn_photon%init (flv_photon, col0) call pol1%init_generic (data%flv_in(1)) call qn_fc1(1)%init (flv = data%flv_in(1), col = col0) call pol2%init_generic (data%flv_in(2)) call qn_fc2(1)%init (flv = data%flv_in(2), col = col0) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel1 = it_hel1%get_quantum_numbers () qn1 = qn_hel1 .merge. qn_fc1(1) qn(1) = qn1 if (data%photon(1)) then qn(3) = qn1; qn(5) = qn_photon else qn(3) = qn_photon; qn(5) = qn1 end if call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel2 = it_hel2%get_quantum_numbers () qn2 = qn_hel2 .merge. qn_fc2(1) qn(2) = qn2 if (data%photon(2)) then qn(4) = qn2; qn(6) = qn_photon else qn(4) = qn_photon; qn(6) = qn2 end if call qn(3:4)%tag_radiated () call sf_int%add_state (qn) call it_hel2%advance () end do call it_hel1%advance () end do ! call pol1%final () ! call pol2%final () call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_radiated ([3,4]) call sf_int%set_outgoing ([5,6]) else if (data%photon(1)) then mask_h(3) = .true. mo2(1) = 0._default else hel_lock(1) = 3; hel_lock(3) = 1 mo2(1) = mi2(1) end if if (data%photon(2)) then mask_h(4) = .true. mo2(2) = 0._default else hel_lock(2) = 4; hel_lock(4) = 2 mo2(2) = mi2(2) end if mask = quantum_numbers_mask (.false., .false., mask_h) call sf_int%base_init (mask(1:4), mi2, [real(default) :: ], mo2, & hel_lock = hel_lock(1:4)) sf_int%data => data call flv_photon%init (PHOTON, data%model) call col0%init () call qn_photon%init (flv_photon, col0) call pol1%init_generic (data%flv_in(1)) call qn_fc1(1)%init (flv = data%flv_in(1), col = col0) call pol2%init_generic (data%flv_in(2)) call qn_fc2(1)%init (flv = data%flv_in(2), col = col0) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel1 = it_hel1%get_quantum_numbers () qn1 = qn_hel1 .merge. qn_fc1(1) qn(1) = qn1 if (data%photon(1)) then qn(3) = qn_photon else qn(3) = qn1 end if call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel2 = it_hel2%get_quantum_numbers () qn2 = qn_hel2 .merge. qn_fc2(1) qn(2) = qn2 if (data%photon(2)) then qn(4) = qn_photon else qn(4) = qn2 end if call sf_int%add_state (qn(1:4)) call it_hel2%advance () end do call it_hel1%advance () end do ! call pol1%final () ! call pol2%final () call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) end if sf_int%status = SF_INITIAL end select if (sf_int%data%generate) then call sf_int%data%rng_factory%make (sf_int%rng_obj%rng) end if end subroutine circe1_init @ %def circe1_init @ \subsection{Kinematics} Refer to the [[data]] component. <>= procedure :: is_generator => circe1_is_generator <>= module function circe1_is_generator (sf_int) result (flag) class(circe1_t), intent(in) :: sf_int logical :: flag end function circe1_is_generator <>= module function circe1_is_generator (sf_int) result (flag) class(circe1_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function circe1_is_generator @ %def circe1_is_generator @ Generate free parameters, if generator mode is on. Otherwise, the parameters will be discarded. <>= procedure :: generate_free => circe1_generate_free <>= module subroutine circe1_generate_free (sf_int, r, rb, x_free) class(circe1_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free end subroutine circe1_generate_free <>= module subroutine circe1_generate_free (sf_int, r, rb, x_free) class(circe1_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free if (sf_int%data%generate) then call circe_generate (r, sf_int%data%get_pdg_int (), sf_int%rng_obj) rb = 1 - r x_free = x_free * product (r) else r = 0 rb= 1 end if end subroutine circe1_generate_free @ %def circe1_generate_free @ Generator mode: depending on the particle codes, call one of the available [[girce]] generators. Illegal particle code combinations should have been caught during data initialization. <>= subroutine circe_generate (x, pdg, rng_obj) real(default), dimension(2), intent(out) :: x integer, dimension(2), intent(in) :: pdg class(rng_obj_t), intent(inout) :: rng_obj real(double) :: xc1, xc2 select case (abs (pdg(1))) case (ELECTRON) select case (abs (pdg(2))) case (ELECTRON) call gircee (xc1, xc2, rng_obj = rng_obj) case (PHOTON) call girceg (xc1, xc2, rng_obj = rng_obj) end select case (PHOTON) select case (abs (pdg(2))) case (ELECTRON) call girceg (xc2, xc1, rng_obj = rng_obj) case (PHOTON) call gircgg (xc1, xc2, rng_obj = rng_obj) end select end select x = [xc1, xc2] end subroutine circe_generate @ %def circe_generate @ Set kinematics. The $r$ values (either from integration or from the generator call above) are copied to $x$ unchanged, and $f$ is unity. We store the $x$ values, so we can use them for the evaluation later. <>= procedure :: complete_kinematics => circe1_complete_kinematics <>= module subroutine circe1_complete_kinematics & (sf_int, x, xb, f, r, rb, map) class(circe1_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map end subroutine circe1_complete_kinematics <>= module subroutine circe1_complete_kinematics & (sf_int, x, xb, f, r, rb, map) class(circe1_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map x = r xb = rb sf_int%x = x sf_int%xb= xb f = 1 if (sf_int%data%with_radiation) then call sf_int%split_momenta (x, xb) else call sf_int%reduce_momenta (x) end if select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end subroutine circe1_complete_kinematics @ %def circe1_complete_kinematics @ Compute inverse kinematics. In generator mode, the $r$ values are meaningless, but we copy them anyway. <>= procedure :: inverse_kinematics => circe1_inverse_kinematics <>= module subroutine circe1_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(circe1_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta end subroutine circe1_inverse_kinematics <>= module subroutine circe1_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(circe1_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta r = x rb = xb sf_int%x = x sf_int%xb= xb f = 1 if (set_mom) then call sf_int%split_momenta (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine circe1_inverse_kinematics @ %def circe1_inverse_kinematics @ \subsection{CIRCE1 application} CIRCE is applied for the two beams at once. We can safely assume that no structure functions are applied before this, so the incoming particles are on-shell electrons/positrons. The scale is ignored. <>= procedure :: apply => circe1_apply <>= module subroutine circe1_apply (sf_int, scale, negative_sf, rescale, i_sub) class(circe1_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub end subroutine circe1_apply <>= module subroutine circe1_apply (sf_int, scale, negative_sf, rescale, i_sub) class(circe1_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default), dimension(2) :: xb real(double), dimension(2) :: xc real(double), parameter :: one = 1 associate (data => sf_int%data) xc = sf_int%x xb = sf_int%xb if (data%generate) then sf_int%f = 1 else sf_int%f = 0 if (all (sf_int%continuum)) then sf_int%f = circe (xc(1), xc(2), data%pdg_in(1), data%pdg_in(2)) end if if (sf_int%continuum(2) .and. sf_int%peak(1)) then sf_int%f = sf_int%f & + circe (one, xc(2), data%pdg_in(1), data%pdg_in(2)) & * peak (xb(1), data%eps) end if if (sf_int%continuum(1) .and. sf_int%peak(2)) then sf_int%f = sf_int%f & + circe (xc(1), one, data%pdg_in(1), data%pdg_in(2)) & * peak (xb(2), data%eps) end if if (all (sf_int%peak)) then sf_int%f = sf_int%f & + circe (one, one, data%pdg_in(1), data%pdg_in(2)) & * peak (xb(1), data%eps) * peak (xb(2), data%eps) end if end if end associate call sf_int%set_matrix_element (cmplx (sf_int%f, kind=default)) sf_int%status = SF_EVALUATED end subroutine circe1_apply @ %def circe1_apply @ This is a smeared delta peak at zero, as an endpoint singularity. We choose an exponentially decreasing function, starting at zero, with integral (from $0$ to $1$) $1-e^{-1/\epsilon}$. For small $\epsilon$, this reduces to one. <>= function peak (x, eps) result (f) real(default), intent(in) :: x, eps real(default) :: f f = exp (-x / eps) / eps end function peak @ %def peak @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_circe1_ut.f90]]>>= <> module sf_circe1_ut use unit_tests use sf_circe1_uti <> <> contains <> end module sf_circe1_ut @ %def sf_circe1_ut @ <<[[sf_circe1_uti.f90]]>>= <> module sf_circe1_uti <> use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use rng_base use sf_aux use sf_base use sf_circe1 use rng_base_ut, only: rng_test_factory_t <> <> contains <> end module sf_circe1_uti @ %def sf_circe1_ut @ API: driver for the unit tests below. <>= public :: sf_circe1_test <>= subroutine sf_circe1_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_circe1_test @ %def sf_circe1_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_circe1_1, "sf_circe1_1", & "structure function configuration", & u, results) <>= public :: sf_circe1_1 <>= subroutine sf_circe1_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_circe1_1" write (u, "(A)") "* Purpose: initialize and display & &CIRCE structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_qed_test () pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON allocate (circe1_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") select type (data) type is (circe1_data_t) call data%init (model, pdg_in, & sqrts = 500._default, & eps = 1e-6_default, & out_photon = [.false., .false.], & ver = 0, & rev = 0, & acc = "SBAND", & chat = 0, & with_radiation = .true.) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe1_1" end subroutine sf_circe1_1 @ %def sf_circe1_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the PDF builtin structure function. <>= call test (sf_circe1_2, "sf_circe1_2", & "structure function instance", & u, results) <>= public :: sf_circe1_2 <>= subroutine sf_circe1_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 type(vector4_t), dimension(4) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_circe1_2" write (u, "(A)") "* Purpose: initialize and fill & &circe1 structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (circe1_data_t :: data) select type (data) type is (circe1_data_t) call data%init (model, pdg_in, & sqrts = 500._default, & eps = 1e-6_default, & out_photon = [.false., .false.], & ver = 0, & rev = 0, & acc = "SBAND", & chat = 0, & with_radiation = .true.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.95,0.85." write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.9_default, 0.8_default] rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1, 2]) call sf_int%seed_kinematics ([k1, k2]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe1_2" end subroutine sf_circe1_2 @ %def sf_circe1_2 @ \subsubsection{Generator mode} Construct and evaluate a structure function object in generator mode. <>= call test (sf_circe1_3, "sf_circe1_3", & "generator mode", & u, results) <>= public :: sf_circe1_3 <>= subroutine sf_circe1_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(rng_factory_t), allocatable :: rng_factory class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, x_free write (u, "(A)") "* Test output: sf_circe1_3" write (u, "(A)") "* Purpose: initialize and fill & &circe1 structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (circe1_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (circe1_data_t) call data%init (model, pdg_in, & sqrts = 500._default, & eps = 1e-6_default, & out_photon = [.false., .false.], & ver = 0, & rev = 0, & acc = "SBAND", & chat = 0, & with_radiation = .true.) call data%set_generator_mode (rng_factory) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) select type (sf_int) type is (circe1_t) call sf_int%rng_obj%rng%init (3) end select write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Generate x" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe1_3" end subroutine sf_circe1_3 @ %def sf_circe1_3 @ \clearpage %------------------------------------------------------------------------ \section{Lepton Collider Beamstrahlung and Photon collider: CIRCE2} <<[[sf_circe2.f90]]>>= <> module sf_circe2 <> <> use os_interface use rng_base use selectors use pdg_arrays use model_data use flavors use polarizations use sf_base use circe2, circe2_rng_t => rng_type !NODEP! <> <> <> interface <> end interface contains <> end module sf_circe2 @ %def sf_circe2 @ <<[[sf_circe2_sub.f90]]>>= <> submodule (sf_circe2) sf_circe2_s use io_units use format_defs, only: FMT_19 use numeric_utils use diagnostics use physics_defs, only: PHOTON, ELECTRON use lorentz use colors use helicities use quantum_numbers use state_matrices implicit none contains <> end submodule sf_circe2_s @ %def sf_circe2_s @ \subsection{Physics} [[CIRCE2]] describes photon spectra Beamstrahlung is applied before ISR. The [[CIRCE2]] implementation has a single structure function for both beams (which makes sense since it has to be switched on or off for both beams simultaneously). \subsection{The CIRCE2 data block} The CIRCE2 parameters are: file and collider specification, incoming (= outgoing) particles. The luminosity is returned by [[circe2_luminosity]]. <>= public :: circe2_data_t <>= type, extends (sf_data_t) :: circe2_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(2) :: flv_in integer, dimension(2) :: pdg_in real(default) :: sqrts = 0 logical :: polarized = .false. logical :: beams_polarized = .false. class(rng_factory_t), allocatable :: rng_factory type(string_t) :: filename type(string_t) :: file type(string_t) :: design real(default) :: lumi = 0 real(default), dimension(4) :: lumi_hel_frac = 0 integer, dimension(0:4) :: h1 = [0, -1, -1, 1, 1] integer, dimension(0:4) :: h2 = [0, -1, 1,-1, 1] integer :: error = 1 contains <> end type circe2_data_t @ %def circe2_data_t <>= type(circe2_state) :: circe2_global_state @ <>= procedure :: init => circe2_data_init <>= module subroutine circe2_data_init (data, os_data, model, pdg_in, & sqrts, polarized, beam_pol, file, design) class(circe2_data_t), intent(out) :: data type(os_data_t), intent(in) :: os_data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), intent(in) :: sqrts logical, intent(in) :: polarized, beam_pol type(string_t), intent(in) :: file, design end subroutine circe2_data_init <>= module subroutine circe2_data_init (data, os_data, model, pdg_in, & sqrts, polarized, beam_pol, file, design) class(circe2_data_t), intent(out) :: data type(os_data_t), intent(in) :: os_data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), intent(in) :: sqrts logical, intent(in) :: polarized, beam_pol type(string_t), intent(in) :: file, design integer :: h data%model => model if (any (pdg_in%get_length () /= 1)) then call msg_fatal ("CIRCE2: incoming beam particles must be unique") end if call data%flv_in(1)%init (pdg_in(1)%get (1), model) call data%flv_in(2)%init (pdg_in(2)%get (1), model) data%pdg_in = data%flv_in%get_pdg () data%sqrts = sqrts data%polarized = polarized data%beams_polarized = beam_pol data%filename = file data%design = design call data%check_file (os_data) call circe2_load (circe2_global_state, trim (char(data%file)), & trim (char(data%design)), data%sqrts, data%error) call data%check () data%lumi = circe2_luminosity (circe2_global_state, data%pdg_in, [0, 0]) if (vanishes (data%lumi)) then call msg_fatal ("CIRCE2: luminosity vanishes for specified beams.") end if if (data%polarized) then do h = 1, 4 data%lumi_hel_frac(h) = & circe2_luminosity (circe2_global_state, data%pdg_in, & [data%h1(h), data%h2(h)]) & / data%lumi end do end if end subroutine circe2_data_init @ %def circe2_data_init @ Activate the generator mode. We import a RNG factory into the data type, which can then spawn RNG generator objects. <>= procedure :: set_generator_mode => circe2_data_set_generator_mode <>= module subroutine circe2_data_set_generator_mode (data, rng_factory) class(circe2_data_t), intent(inout) :: data class(rng_factory_t), intent(inout), allocatable :: rng_factory end subroutine circe2_data_set_generator_mode <>= module subroutine circe2_data_set_generator_mode (data, rng_factory) class(circe2_data_t), intent(inout) :: data class(rng_factory_t), intent(inout), allocatable :: rng_factory call move_alloc (from = rng_factory, to = data%rng_factory) end subroutine circe2_data_set_generator_mode @ %def circe2_data_set_generator_mode @ Check whether the requested data file is in the system directory or in the current directory. <>= procedure :: check_file => circe2_check_file <>= module subroutine circe2_check_file (data, os_data) class(circe2_data_t), intent(inout) :: data type(os_data_t), intent(in) :: os_data end subroutine circe2_check_file <>= module subroutine circe2_check_file (data, os_data) class(circe2_data_t), intent(inout) :: data type(os_data_t), intent(in) :: os_data logical :: exist type(string_t) :: file file = data%filename if (file == "") & call msg_fatal ("CIRCE2: $circe2_file is not set") inquire (file = char (file), exist = exist) if (exist) then data%file = file else file = os_data%whizard_circe2path // "/" // data%filename inquire (file = char (file), exist = exist) if (exist) then data%file = file else call msg_fatal ("CIRCE2: data file '" // char (data%filename) & // "' not found") end if end if end subroutine circe2_check_file @ %def circe2_check_file @ Handle error conditions. <>= procedure :: check => circe2_data_check <>= module subroutine circe2_data_check (data) class(circe2_data_t), intent(in) :: data end subroutine circe2_data_check <>= module subroutine circe2_data_check (data) class(circe2_data_t), intent(in) :: data type(flavor_t) :: flv_photon, flv_electron call flv_photon%init (PHOTON, data%model) if (.not. flv_photon%is_defined ()) then call msg_fatal ("CIRCE2: model must contain photon") end if call flv_electron%init (ELECTRON, data%model) if (.not. flv_electron%is_defined ()) then call msg_fatal ("CIRCE2: model must contain electron") end if if (any (abs (data%pdg_in) /= PHOTON .and. abs (data%pdg_in) /= ELECTRON)) & then call msg_fatal ("CIRCE2: applicable only for e+e- or photon collisions") end if select case (data%error) case (-1) call msg_fatal ("CIRCE2: data file not found.") case (-2) call msg_fatal ("CIRCE2: beam setup does not match data file.") case (-3) call msg_fatal ("CIRCE2: invalid format of data file.") case (-4) call msg_fatal ("CIRCE2: data file too large.") end select end subroutine circe2_data_check @ %def circe2_data_check @ Output <>= procedure :: write => circe2_data_write <>= module subroutine circe2_data_write (data, unit, verbose) class(circe2_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine circe2_data_write <>= module subroutine circe2_data_write (data, unit, verbose) class(circe2_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, h logical :: verb verb = .false.; if (present (verbose)) verb = verbose u = given_output_unit (unit) write (u, "(1x,A)") "CIRCE2 data:" write (u, "(3x,A,A)") "file = ", char(data%filename) write (u, "(3x,A,A)") "design = ", char(data%design) write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", data%sqrts write (u, "(3x,A,A,A,A)") "prt_in = ", & char (data%flv_in(1)%get_name ()), & ", ", char (data%flv_in(2)%get_name ()) write (u, "(3x,A,L1)") "polarized = ", data%polarized write (u, "(3x,A,L1)") "beams pol. = ", data%beams_polarized write (u, "(3x,A," // FMT_19 // ")") "luminosity = ", data%lumi if (data%polarized) then do h = 1, 4 write (u, "(6x,'(',I2,1x,I2,')',1x,'=',1x)", advance="no") & data%h1(h), data%h2(h) write (u, "(6x, " // FMT_19 // ")") data%lumi_hel_frac(h) end do end if if (verb) then call data%rng_factory%write (u) end if end subroutine circe2_data_write @ %def circe2_data_write @ This is always in generator mode. <>= procedure :: is_generator => circe2_data_is_generator <>= module function circe2_data_is_generator (data) result (flag) class(circe2_data_t), intent(in) :: data logical :: flag end function circe2_data_is_generator <>= module function circe2_data_is_generator (data) result (flag) class(circe2_data_t), intent(in) :: data logical :: flag flag = .true. end function circe2_data_is_generator @ %def circe2_data_is_generator @ The number of parameters is two, collinear splitting for the two beams. <>= procedure :: get_n_par => circe2_data_get_n_par <>= module function circe2_data_get_n_par (data) result (n) class(circe2_data_t), intent(in) :: data integer :: n end function circe2_data_get_n_par <>= module function circe2_data_get_n_par (data) result (n) class(circe2_data_t), intent(in) :: data integer :: n n = 2 end function circe2_data_get_n_par @ %def circe2_data_get_n_par @ Return the outgoing particles PDG codes. They are equal to the incoming ones. <>= procedure :: get_pdg_out => circe2_data_get_pdg_out <>= module subroutine circe2_data_get_pdg_out (data, pdg_out) class(circe2_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out end subroutine circe2_data_get_pdg_out <>= module subroutine circe2_data_get_pdg_out (data, pdg_out) class(circe2_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n pdg_out(i) = data%pdg_in(i) end do end subroutine circe2_data_get_pdg_out @ %def circe2_data_get_pdg_out @ Allocate the interaction record. Due to gfortran 7/8/9 bug has to remain in the main module. <>= procedure :: allocate_sf_int => circe2_data_allocate_sf_int <>= subroutine circe2_data_allocate_sf_int (data, sf_int) class(circe2_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (circe2_t :: sf_int) end subroutine circe2_data_allocate_sf_int @ %def circe2_data_allocate_sf_int @ Return the beam file. <>= procedure :: get_beam_file => circe2_data_get_beam_file <>= module function circe2_data_get_beam_file (data) result (file) class(circe2_data_t), intent(in) :: data type(string_t) :: file end function circe2_data_get_beam_file <>= module function circe2_data_get_beam_file (data) result (file) class(circe2_data_t), intent(in) :: data type(string_t) :: file file = "CIRCE2: " // data%filename end function circe2_data_get_beam_file @ %def circe2_data_get_beam_file @ \subsection{Random Number Generator for CIRCE} The CIRCE implementation now supports a generic random-number generator object that allows for a local state as a component. To support this, we must extend the abstract type provided by CIRCE and delegate the generator call to the (also abstract) RNG used by WHIZARD. <>= type, extends (circe2_rng_t) :: rng_obj_t class(rng_t), allocatable :: rng contains procedure :: generate => rng_obj_generate end type rng_obj_t @ %def rng_obj_t <>= module subroutine rng_obj_generate (rng_obj, u) class(rng_obj_t), intent(inout) :: rng_obj real(default), intent(out) :: u end subroutine rng_obj_generate <>= module subroutine rng_obj_generate (rng_obj, u) class(rng_obj_t), intent(inout) :: rng_obj real(default), intent(out) :: u real(default) :: x call rng_obj%rng%generate (x) u = x end subroutine rng_obj_generate @ %def rng_obj_generate @ \subsection{The CIRCE2 object} For CIRCE2 spectra it does not make sense to describe the state matrix as a radiation interaction, even if photons originate from laser backscattering. Instead, it is a $2\to 2$ interaction where the incoming particles are identical to the outgoing ones. The current implementation of CIRCE2 does support polarization and classical correlations, but no entanglement, so the density matrix of the outgoing particles is diagonal. The incoming particles are unpolarized (user-defined polarization for beams is meaningless, since polarization is described by the data file). The outgoing particles are polarized or polarization-averaged, depending on user request. When assigning matrix elements, we scan the previously initialized state matrix. For each entry, we extract helicity and call the structure function. In the unpolarized case, the helicity is undefined and replaced by value zero. In the polarized case, there are four entries. If the generator is used, only one entry is nonzero in each call. Which one, is determined by comparing with a previously (randomly, distributed by relative luminosity) selected pair of helicities. <>= public :: circe2_t <>= type, extends (sf_int_t) :: circe2_t type(circe2_data_t), pointer :: data => null () type(rng_obj_t) :: rng_obj type(selector_t) :: selector integer :: h_sel = 0 contains <> end type circe2_t @ %def circe2_t @ Type string: show file and design of [[CIRCE2]] structure function. <>= procedure :: type_string => circe2_type_string <>= module function circe2_type_string (object) result (string) class(circe2_t), intent(in) :: object type(string_t) :: string end function circe2_type_string <>= module function circe2_type_string (object) result (string) class(circe2_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "CIRCE2: " // object%data%design else string = "CIRCE2: [undefined]" end if end function circe2_type_string @ %def circe2_type_string @ @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => circe2_write <>= module subroutine circe2_write (object, unit, testflag) class(circe2_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine circe2_write <>= module subroutine circe2_write (object, unit, testflag) class(circe2_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "CIRCE2 data: [undefined]" end if end subroutine circe2_write @ %def circe2_write @ <>= procedure :: init => circe2_init <>= module subroutine circe2_init (sf_int, data) class(circe2_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data end subroutine circe2_init <>= module subroutine circe2_init (sf_int, data) class(circe2_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data logical, dimension(4) :: mask_h real(default), dimension(2) :: m2_array real(default), dimension(0) :: null_array type(quantum_numbers_mask_t), dimension(4) :: mask type(quantum_numbers_t), dimension(4) :: qn type(helicity_t) :: hel type(color_t) :: col0 integer :: h select type (data) type is (circe2_data_t) if (data%polarized .and. data%beams_polarized) then call msg_fatal ("CIRCE2: Beam polarization can't be set & &for polarized data file") else if (data%beams_polarized) then call msg_warning ("CIRCE2: User-defined beam polarization set & &for unpolarized CIRCE2 data file") end if mask_h(1:2) = .not. data%beams_polarized mask_h(3:4) = .not. (data%polarized .or. data%beams_polarized) mask = quantum_numbers_mask (.false., .false., mask_h) m2_array(:) = (data%flv_in(:)%get_mass ())**2 call sf_int%base_init (mask, m2_array, null_array, m2_array) sf_int%data => data if (data%polarized) then if (vanishes (sum (data%lumi_hel_frac)) .or. & any (data%lumi_hel_frac < 0)) then call msg_fatal ("CIRCE2: Helicity-dependent lumi " & // "fractions all vanish or", & [var_str ("are negative: Please inspect the " & // "CIRCE2 file or "), & var_str ("switch off the polarized" // & " option for CIRCE2.")]) else call sf_int%selector%init (data%lumi_hel_frac) end if end if call col0%init () if (data%beams_polarized) then do h = 1, 4 call hel%init (data%h1(h)) call qn(1)%init & (flv = data%flv_in(1), col = col0, hel = hel) call qn(3)%init & (flv = data%flv_in(1), col = col0, hel = hel) call hel%init (data%h2(h)) call qn(2)%init & (flv = data%flv_in(2), col = col0, hel = hel) call qn(4)%init & (flv = data%flv_in(2), col = col0, hel = hel) call sf_int%add_state (qn) end do else if (data%polarized) then call qn(1)%init (flv = data%flv_in(1), col = col0) call qn(2)%init (flv = data%flv_in(2), col = col0) do h = 1, 4 call hel%init (data%h1(h)) call qn(3)%init & (flv = data%flv_in(1), col = col0, hel = hel) call hel%init (data%h2(h)) call qn(4)%init & (flv = data%flv_in(2), col = col0, hel = hel) call sf_int%add_state (qn) end do else call qn(1)%init (flv = data%flv_in(1), col = col0) call qn(2)%init (flv = data%flv_in(2), col = col0) call qn(3)%init (flv = data%flv_in(1), col = col0) call qn(4)%init (flv = data%flv_in(2), col = col0) call sf_int%add_state (qn) end if call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) call sf_int%data%rng_factory%make (sf_int%rng_obj%rng) sf_int%status = SF_INITIAL end select end subroutine circe2_init @ %def circe2_init @ \subsection{Kinematics} Refer to the [[data]] component. <>= procedure :: is_generator => circe2_is_generator <>= module function circe2_is_generator (sf_int) result (flag) class(circe2_t), intent(in) :: sf_int logical :: flag end function circe2_is_generator <>= module function circe2_is_generator (sf_int) result (flag) class(circe2_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function circe2_is_generator @ %def circe2_is_generator @ Generate free parameters. We first select a helicity, which we have to store, then generate $x$ values for that helicity. <>= procedure :: generate_free => circe2_generate_whizard_free <>= module subroutine circe2_generate_whizard_free (sf_int, r, rb, x_free) class(circe2_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free end subroutine circe2_generate_whizard_free <>= module subroutine circe2_generate_whizard_free (sf_int, r, rb, x_free) class(circe2_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free integer :: h_sel if (sf_int%data%polarized) then call sf_int%selector%generate (sf_int%rng_obj%rng, h_sel) else h_sel = 0 end if sf_int%h_sel = h_sel call circe2_generate_whizard (r, sf_int%data%pdg_in, & [sf_int%data%h1(h_sel), sf_int%data%h2(h_sel)], & sf_int%rng_obj) rb = 1 - r x_free = x_free * product (r) end subroutine circe2_generate_whizard_free @ %def circe2_generate_whizard_free @ Generator mode: call the CIRCE2 generator for the given particles and helicities. (For unpolarized generation, helicities are zero.) <>= module subroutine circe2_generate_whizard (x, pdg, hel, rng_obj) real(default), dimension(2), intent(out) :: x integer, dimension(2), intent(in) :: pdg integer, dimension(2), intent(in) :: hel class(rng_obj_t), intent(inout) :: rng_obj end subroutine circe2_generate_whizard <>= module subroutine circe2_generate_whizard (x, pdg, hel, rng_obj) real(default), dimension(2), intent(out) :: x integer, dimension(2), intent(in) :: pdg integer, dimension(2), intent(in) :: hel class(rng_obj_t), intent(inout) :: rng_obj call circe2_generate (circe2_global_state, rng_obj, x, pdg, hel) end subroutine circe2_generate_whizard @ %def circe2_generate_whizard @ Set kinematics. Trivial here. <>= procedure :: complete_kinematics => circe2_complete_kinematics <>= module subroutine circe2_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(circe2_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map end subroutine circe2_complete_kinematics <>= module subroutine circe2_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(circe2_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("CIRCE2: map flag not supported") else x = r xb= rb f = 1 end if call sf_int%reduce_momenta (x) end subroutine circe2_complete_kinematics @ %def circe2_complete_kinematics @ Compute inverse kinematics. <>= procedure :: inverse_kinematics => circe2_inverse_kinematics <>= module subroutine circe2_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(circe2_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta end subroutine circe2_inverse_kinematics <>= module subroutine circe2_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(circe2_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("CIRCE2: map flag not supported") else r = x rb= xb f = 1 end if if (set_mom) then call sf_int%reduce_momenta (x) end if end subroutine circe2_inverse_kinematics @ %def circe2_inverse_kinematics @ \subsection{CIRCE2 application} This function works on both beams. In polarized mode, we set only the selected helicity. In unpolarized mode, the interaction has only one entry, and the factor is unity. <>= procedure :: apply => circe2_apply <>= module subroutine circe2_apply (sf_int, scale, negative_sf, rescale, i_sub) class(circe2_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub end subroutine circe2_apply <>= module subroutine circe2_apply (sf_int, scale, negative_sf, rescale, i_sub) class(circe2_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub complex(default) :: f associate (data => sf_int%data) f = 1 if (data%beams_polarized) then call sf_int%set_matrix_element (f) else if (data%polarized) then call sf_int%set_matrix_element (sf_int%h_sel, f) else call sf_int%set_matrix_element (1, f) end if end associate sf_int%status = SF_EVALUATED end subroutine circe2_apply @ %def circe2_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_circe2_ut.f90]]>>= <> module sf_circe2_ut use unit_tests use sf_circe2_uti <> <> contains <> end module sf_circe2_ut @ %def sf_circe2_ut @ <<[[sf_circe2_uti.f90]]>>= <> module sf_circe2_uti <> <> use os_interface use physics_defs, only: PHOTON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use rng_base use sf_aux use sf_base use sf_circe2 use rng_base_ut, only: rng_test_factory_t <> <> contains <> end module sf_circe2_uti @ %def sf_circe2_ut @ API: driver for the unit tests below. <>= public :: sf_circe2_test <>= subroutine sf_circe2_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_circe2_test @ %def sf_circe2_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_circe2_1, "sf_circe2_1", & "structure function configuration", & u, results) <>= public :: sf_circe2_1 <>= subroutine sf_circe2_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data class(rng_factory_t), allocatable :: rng_factory write (u, "(A)") "* Test output: sf_circe2_1" write (u, "(A)") "* Purpose: initialize and display & &CIRCE structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call os_data%init () call model%init_qed_test () pdg_in(1) = PHOTON pdg_in(2) = PHOTON allocate (circe2_data_t :: data) allocate (rng_test_factory_t :: rng_factory) write (u, "(A)") write (u, "(A)") "* Initialize (unpolarized)" write (u, "(A)") select type (data) type is (circe2_data_t) call data%init (os_data, model, pdg_in, & sqrts = 500._default, & polarized = .false., & beam_pol = .false., & file = var_str ("teslagg_500_polavg.circe"), & design = var_str ("TESLA/GG")) call data%set_generator_mode (rng_factory) end select call data%write (u, verbose = .true.) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 write (u, "(A)") write (u, "(A)") "* Initialize (polarized)" write (u, "(A)") allocate (rng_test_factory_t :: rng_factory) select type (data) type is (circe2_data_t) call data%init (os_data, model, pdg_in, & sqrts = 500._default, & polarized = .true., & beam_pol = .false., & file = var_str ("teslagg_500.circe"), & design = var_str ("TESLA/GG")) call data%set_generator_mode (rng_factory) end select call data%write (u, verbose = .true.) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe2_1" end subroutine sf_circe2_1 @ %def sf_circe2_1 @ \subsubsection{Generator mode, unpolarized} Construct and evaluate a structure function object in generator mode. <>= call test (sf_circe2_2, "sf_circe2_2", & "generator, unpolarized", & u, results) <>= public :: sf_circe2_2 <>= subroutine sf_circe2_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(rng_factory_t), allocatable :: rng_factory class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, x_free write (u, "(A)") "* Test output: sf_circe2_2" write (u, "(A)") "* Purpose: initialize and fill & &circe2 structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call os_data%init () call model%init_qed_test () call flv(1)%init (PHOTON, model) call flv(2)%init (PHOTON, model) pdg_in(1) = PHOTON pdg_in(2) = PHOTON call reset_interaction_counter () allocate (circe2_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (circe2_data_t) call data%init (os_data, model, pdg_in, & sqrts = 500._default, & polarized = .false., & beam_pol = .false., & file = var_str ("teslagg_500_polavg.circe"), & design = var_str ("TESLA/GG")) call data%set_generator_mode (rng_factory) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) select type (sf_int) type is (circe2_t) call sf_int%rng_obj%rng%init (3) end select write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Generate x" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe2_2" end subroutine sf_circe2_2 @ %def sf_circe2_2 @ \subsubsection{Generator mode, polarized} Construct and evaluate a structure function object in generator mode. <>= call test (sf_circe2_3, "sf_circe2_3", & "generator, polarized", & u, results) <>= public :: sf_circe2_3 <>= subroutine sf_circe2_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(rng_factory_t), allocatable :: rng_factory class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, x_free write (u, "(A)") "* Test output: sf_circe2_3" write (u, "(A)") "* Purpose: initialize and fill & &circe2 structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call os_data%init () call model%init_qed_test () call flv(1)%init (PHOTON, model) call flv(2)%init (PHOTON, model) pdg_in(1) = PHOTON pdg_in(2) = PHOTON call reset_interaction_counter () allocate (circe2_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (circe2_data_t) call data%init (os_data, model, pdg_in, & sqrts = 500._default, & polarized = .true., & beam_pol = .false., & file = var_str ("teslagg_500.circe"), & design = var_str ("TESLA/GG")) call data%set_generator_mode (rng_factory) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) select type (sf_int) type is (circe2_t) call sf_int%rng_obj%rng%init (3) end select write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Generate x" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe2_3" end subroutine sf_circe2_3 @ %def sf_circe2_3 @ \clearpage %------------------------------------------------------------------------ \section{HOPPET interface} Interface to the HOPPET wrapper necessary to perform the LO vs. NLO matching of processes containing an initial b quark. <<[[hoppet_interface.f90]]>>= <> module hoppet_interface use lhapdf !NODEP! <> public :: hoppet_init, hoppet_eval contains subroutine hoppet_init (pdf_builtin, pdf, pdf_id) logical, intent(in) :: pdf_builtin type(lhapdf_pdf_t), intent(inout), optional :: pdf integer, intent(in), optional :: pdf_id external InitForWhizard call InitForWhizard (pdf_builtin, pdf, pdf_id) end subroutine hoppet_init subroutine hoppet_eval (x, q, f) double precision, intent(in) :: x, q double precision, intent(out) :: f(-6:6) external EvalForWhizard call EvalForWhizard (x, q, f) end subroutine hoppet_eval end module hoppet_interface @ %def hoppet_interface @ \clearpage %------------------------------------------------------------------------ \section{Builtin PDF sets} For convenience in order not to depend on the external package LHAPDF, we ship some PDFs with WHIZARD. @ \subsection{The module} <<[[sf_pdf_builtin.f90]]>>= <> module sf_pdf_builtin <> use kinds, only: double <> use sm_qcd use pdg_arrays use model_data use flavors use polarizations use sf_base <> <> <> interface <> end interface contains <> end module sf_pdf_builtin @ %def sf_pdf_builtin @ <<[[sf_pdf_builtin_sub.f90]]>>= <> submodule (sf_pdf_builtin) sf_pdf_builtin_s use io_units use format_defs, only: FMT_17 use diagnostics use os_interface use physics_defs, only: PROTON, PHOTON, GLUON use physics_defs, only: HADRON_REMNANT_SINGLET use physics_defs, only: HADRON_REMNANT_TRIPLET use physics_defs, only: HADRON_REMNANT_OCTET use lorentz use colors use quantum_numbers use state_matrices use pdf_builtin !NODEP! use hoppet_interface implicit none <> contains <> end submodule sf_pdf_builtin_s @ %def sf_pdf_builtin_s @ \subsection{Codes for default PDF sets} <>= character(*), parameter :: PDF_BUILTIN_DEFAULT_PROTON = "CTEQ6L" ! character(*), parameter :: PDF_BUILTIN_DEFAULT_PION = "NONE" ! character(*), parameter :: PDF_BUILTIN_DEFAULT_PHOTON = "MRST2004QEDp" @ %def PDF_BUILTIN_DEFAULT_SET @ \subsection{The PDF builtin data block} The data block holds the incoming flavor (which has to be proton, pion, or photon), the corresponding pointer to the global access data (1, 2, or 3), the flag [[invert]] which is set for an antiproton, the bounds as returned by LHAPDF for the specified set, and a mask that determines which partons will be actually in use. <>= public :: pdf_builtin_data_t <>= type, extends (sf_data_t) :: pdf_builtin_data_t private integer :: id = -1 type (string_t) :: name class(model_data_t), pointer :: model => null () type(flavor_t) :: flv_in logical :: invert logical :: has_photon logical :: photon logical, dimension(-6:6) :: mask logical :: mask_photon logical :: hoppet_b_matching = .false. contains <> end type pdf_builtin_data_t @ %def pdf_builtin_data_t @ Generate PDF data and initialize the requested set. Pion and photon PDFs are disabled at the moment until we ship appropiate structure functions. needed. <>= procedure :: init => pdf_builtin_data_init <>= module subroutine pdf_builtin_data_init (data, & model, pdg_in, name, path, hoppet_b_matching) class(pdf_builtin_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in type(string_t), intent(in) :: name type(string_t), intent(in) :: path logical, intent(in), optional :: hoppet_b_matching end subroutine pdf_builtin_data_init <>= module subroutine pdf_builtin_data_init (data, & model, pdg_in, name, path, hoppet_b_matching) class(pdf_builtin_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in type(string_t), intent(in) :: name type(string_t), intent(in) :: path logical, intent(in), optional :: hoppet_b_matching data%model => model if (pdg_in%get_length () /= 1) & call msg_fatal ("PDF: incoming particle must be unique") call data%flv_in%init (pdg_in%get (1), model) data%mask = .true. data%mask_photon = .true. select case (pdg_in%get (1)) case (PROTON) data%name = var_str (PDF_BUILTIN_DEFAULT_PROTON) data%invert = .false. data%photon = .false. case (-PROTON) data%name = var_str (PDF_BUILTIN_DEFAULT_PROTON) data%invert = .true. data%photon = .false. ! case (PIPLUS) ! data%name = var_str (PDF_BUILTIN_DEFAULT_PION) ! data%invert = .false. ! data%photon = .false. ! case (-PIPLUS) ! data%name = var_str (PDF_BUILTIN_DEFAULT_PION) ! data%invert = .true. ! data%photon = .false. ! case (PHOTON) ! data%name = var_str (PDF_BUILTIN_DEFAULT_PHOTON) ! data%invert = .false. ! data%photon = .true. case default call msg_fatal ("PDF: " & // "incoming particle must either proton or antiproton.") return end select data%name = name data%id = pdf_get_id (data%name) if (data%id < 0) call msg_fatal ("unknown PDF set " // char (data%name)) data%has_photon = pdf_provides_photon (data%id) if (present (hoppet_b_matching)) data%hoppet_b_matching = hoppet_b_matching call pdf_init (data%id, path) if (data%hoppet_b_matching) call hoppet_init (.true., pdf_id = data%id) end subroutine pdf_builtin_data_init @ %def pdf_builtin_data_init @ Enable/disable partons explicitly. If a mask entry is true, applying the PDF will generate the corresponding flavor on output. <>= procedure :: set_mask => pdf_builtin_data_set_mask <>= module subroutine pdf_builtin_data_set_mask (data, mask) class(pdf_builtin_data_t), intent(inout) :: data logical, dimension(-6:6), intent(in) :: mask end subroutine pdf_builtin_data_set_mask <>= module subroutine pdf_builtin_data_set_mask (data, mask) class(pdf_builtin_data_t), intent(inout) :: data logical, dimension(-6:6), intent(in) :: mask data%mask = mask end subroutine pdf_builtin_data_set_mask @ %def pdf_builtin_data_set_mask @ Output. <>= procedure :: write => pdf_builtin_data_write <>= module subroutine pdf_builtin_data_write (data, unit, verbose) class(pdf_builtin_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine pdf_builtin_data_write <>= module subroutine pdf_builtin_data_write (data, unit, verbose) class(pdf_builtin_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "PDF builtin data:" if (data%id < 0) then write (u, "(3x,A)") "[undefined]" return end if write (u, "(3x,A)", advance="no") "flavor = " call data%flv_in%write (u); write (u, *) write (u, "(3x,A,A)") "name = ", char (data%name) write (u, "(3x,A,L1)") "invert = ", data%invert write (u, "(3x,A,L1)") "has photon = ", data%has_photon write (u, "(3x,A,6(1x,L1),1x,A,1x,L1,1x,A,6(1x,L1))") & "mask =", & data%mask(-6:-1), "*", data%mask(0), "*", data%mask(1:6) write (u, "(3x,A,L1)") "photon mask = ", data%mask_photon write (u, "(3x,A,L1)") "hoppet_b = ", data%hoppet_b_matching end subroutine pdf_builtin_data_write @ %def pdf_builtin_data_write @ The number of parameters is one. We do not generate transverse momentum. <>= procedure :: get_n_par => pdf_builtin_data_get_n_par <>= module function pdf_builtin_data_get_n_par (data) result (n) class(pdf_builtin_data_t), intent(in) :: data integer :: n end function pdf_builtin_data_get_n_par <>= module function pdf_builtin_data_get_n_par (data) result (n) class(pdf_builtin_data_t), intent(in) :: data integer :: n n = 1 end function pdf_builtin_data_get_n_par @ %def pdf_builtin_data_get_n_par @ Return the outgoing particle PDG codes. This is based on the mask. <>= procedure :: get_pdg_out => pdf_builtin_data_get_pdg_out <>= module subroutine pdf_builtin_data_get_pdg_out (data, pdg_out) class(pdf_builtin_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out end subroutine pdf_builtin_data_get_pdg_out <>= module subroutine pdf_builtin_data_get_pdg_out (data, pdg_out) class(pdf_builtin_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer, dimension(:), allocatable :: pdg1 integer :: n, np, i n = count (data%mask) np = 0; if (data%has_photon .and. data%mask_photon) np = 1 allocate (pdg1 (n + np)) pdg1(1:n) = pack ([(i, i = -6, 6)], data%mask) if (np == 1) pdg1(n+np) = PHOTON pdg_out(1) = pdg1 end subroutine pdf_builtin_data_get_pdg_out @ %def pdf_builtin_data_get_pdg_out @ Allocate the interaction record. Due to gfortran 7/8/9 bug this has to remain in the main module. <>= procedure :: allocate_sf_int => pdf_builtin_data_allocate_sf_int <>= subroutine pdf_builtin_data_allocate_sf_int (data, sf_int) class(pdf_builtin_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (pdf_builtin_t :: sf_int) end subroutine pdf_builtin_data_allocate_sf_int @ %def pdf_builtin_data_allocate_sf_int @ Return the numerical PDF set index. <>= procedure :: get_pdf_set => pdf_builtin_data_get_pdf_set <>= elemental module function pdf_builtin_data_get_pdf_set & (data) result (pdf_set) class(pdf_builtin_data_t), intent(in) :: data integer :: pdf_set end function pdf_builtin_data_get_pdf_set <>= elemental module function pdf_builtin_data_get_pdf_set & (data) result (pdf_set) class(pdf_builtin_data_t), intent(in) :: data integer :: pdf_set pdf_set = data%id end function pdf_builtin_data_get_pdf_set @ %def pdf_builtin_data_get_pdf_set @ \subsection{The PDF object} The PDF $1\to 2$ interaction which describes the splitting of an (anti)proton into a parton and a beam remnant. We stay in the strict forward-splitting limit, but allow some invariant mass for the beam remnant such that the outgoing parton is exactly massless. For a real event, we would replace this by a parton cascade, where the outgoing partons have virtuality as dictated by parton-shower kinematics, and transverse momentum is generated. The PDF application is a $1\to 2$ splitting process, where the particles are ordered as (hadron, remnant, parton). Polarization is ignored completely. The beam particle is colorless, while partons and beam remnant carry color. The remnant gets a special flavor code. <>= public :: pdf_builtin_t <>= type, extends (sf_int_t) :: pdf_builtin_t type(pdf_builtin_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: q = 0 contains <> end type pdf_builtin_t @ %def pdf_builtin_t @ Type string: display the chosen PDF set. <>= procedure :: type_string => pdf_builtin_type_string <>= module function pdf_builtin_type_string (object) result (string) class(pdf_builtin_t), intent(in) :: object type(string_t) :: string end function pdf_builtin_type_string <>= module function pdf_builtin_type_string (object) result (string) class(pdf_builtin_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "PDF builtin: " // object%data%name else string = "PDF builtin: [undefined]" end if end function pdf_builtin_type_string @ %def pdf_builtin_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => pdf_builtin_write <>= module subroutine pdf_builtin_write (object, unit, testflag) class(pdf_builtin_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine pdf_builtin_write <>= module subroutine pdf_builtin_write (object, unit, testflag) class(pdf_builtin_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_17 // ")") "x =", object%x if (object%status >= SF_FAILED_EVALUATION) then write (u, "(3x,A," // FMT_17 // ")") "Q =", object%q end if end if call object%base_write (u, testflag) else write (u, "(1x,A)") "PDF builtin data: [undefined]" end if end subroutine pdf_builtin_write @ %def pdf_builtin_write @ Initialize. We know that [[data]] will be of concrete type [[sf_test_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass, but keep the radiated mass zero. Optionally, we can provide minimum and maximum values for the momentum transfer. <>= procedure :: init => pdf_builtin_init <>= module subroutine pdf_builtin_init (sf_int, data) class(pdf_builtin_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data end subroutine pdf_builtin_init <>= module subroutine pdf_builtin_init (sf_int, data) class(pdf_builtin_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask type(flavor_t) :: flv, flv_remnant type(color_t) :: col0 type(quantum_numbers_t), dimension(3) :: qn integer :: i select type (data) type is (pdf_builtin_data_t) mask = quantum_numbers_mask (.false., .false., .true.) call col0%init () call sf_int%base_init (mask, [0._default], [0._default], [0._default]) sf_int%data => data do i = -6, 6 if (data%mask(i)) then call qn(1)%init (data%flv_in, col = col0) if (i == 0) then call flv%init (GLUON, data%model) call flv_remnant%init (HADRON_REMNANT_OCTET, data%model) else call flv%init (i, data%model) call flv_remnant%init & (sign (HADRON_REMNANT_TRIPLET, -i), data%model) end if call qn(2)%init ( & flv = flv_remnant, col = color_from_flavor (flv_remnant, 1)) call qn(2)%tag_radiated () call qn(3)%init ( & flv = flv, col = color_from_flavor (flv, 1, reverse=.true.)) call sf_int%add_state (qn) end if end do if (data%has_photon .and. data%mask_photon) then call flv%init (PHOTON, data%model) call flv_remnant%init (HADRON_REMNANT_SINGLET, data%model) call qn(2)%init (flv = flv_remnant, & col = color_from_flavor (flv_remnant, 1)) call qn(2)%tag_radiated () call qn(3)%init (flv = flv, & col = color_from_flavor (flv, 1, reverse = .true.)) call sf_int%add_state (qn) end if call sf_int%freeze () call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) sf_int%status = SF_INITIAL end select end subroutine pdf_builtin_init @ %def pdf_builtin_init @ \subsection{Kinematics} Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, we are asked to provide an efficient mapping. For the test case, we set $x=r^2$ and consequently $f(r)=2r$. <>= procedure :: complete_kinematics => pdf_builtin_complete_kinematics <>= module subroutine pdf_builtin_complete_kinematics & (sf_int, x, xb, f, r, rb, map) class(pdf_builtin_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map end subroutine pdf_builtin_complete_kinematics <>= module subroutine pdf_builtin_complete_kinematics & (sf_int, x, xb, f, r, rb, map) class(pdf_builtin_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("PDF builtin: map flag not supported") else x(1) = r(1) xb(1)= rb(1) f = 1 end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_DONE_KINEMATICS) sf_int%x = x(1) case (SF_FAILED_KINEMATICS) sf_int%x = 0 f = 0 end select end subroutine pdf_builtin_complete_kinematics @ %def pdf_builtin_complete_kinematics @ Overriding the default method: we compute the [[x]] value from the momentum configuration. In this specific case, we also set the internally stored $x$ value, so it can be used in the following routine. <>= procedure :: recover_x => pdf_builtin_recover_x <>= module subroutine pdf_builtin_recover_x (sf_int, x, xb, x_free) class(pdf_builtin_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free end subroutine pdf_builtin_recover_x <>= module subroutine pdf_builtin_recover_x (sf_int, x, xb, x_free) class(pdf_builtin_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) end subroutine pdf_builtin_recover_x @ %def sf_pdf_builtin_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => pdf_builtin_inverse_kinematics <>= module subroutine pdf_builtin_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(pdf_builtin_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta end subroutine pdf_builtin_inverse_kinematics <>= module subroutine pdf_builtin_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(pdf_builtin_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("PDF builtin: map flag not supported") else r(1) = x(1) rb(1)= xb(1) f = 1 end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine pdf_builtin_inverse_kinematics @ %def pdf_builtin_inverse_kinematics @ \subsection{Structure function} Once the scale is also known, we can actually call the PDF and set the values. Contrary to LHAPDF, the wrapper already takes care of adjusting to the $x$ and $Q$ bounds. Account for the Jacobian. The parameter [[negative_sf]] is necessary to determine if we allow for negative PDF values. The class [[rescale]] gives rescaling prescription for NLO convolution of the structure function in combination with [[i_sub]]. <>= procedure :: apply => pdf_builtin_apply <>= module subroutine pdf_builtin_apply & (sf_int, scale, negative_sf, rescale, i_sub) class(pdf_builtin_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub end subroutine pdf_builtin_apply <>= module subroutine pdf_builtin_apply & (sf_int, scale, negative_sf, rescale, i_sub) class(pdf_builtin_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default), dimension(-6:6) :: ff real(double), dimension(-6:6) :: ff_dbl real(default) :: x, fph real(double) :: xx, qq complex(default), dimension(:), allocatable :: fc integer :: i, j_sub, i_sub_opt logical :: negative_sf_opt i_sub_opt = 0; if (present (i_sub)) i_sub_opt = i_sub negative_sf_opt = .false.; if (present(negative_sf)) negative_sf_opt = negative_sf associate (data => sf_int%data) sf_int%q = scale x = sf_int%x if (present (rescale)) call rescale%apply (x) if (debug2_active (D_BEAMS)) then call msg_debug2 (D_BEAMS, "pdf_builtin_apply") call msg_debug2 (D_BEAMS, "rescale: ", present(rescale)) call msg_debug2 (D_BEAMS, "i_sub: ", i_sub_opt) call msg_debug2 (D_BEAMS, "x: ", x) end if xx = x qq = scale if (data%invert) then if (data%has_photon) then call pdf_evolve (data%id, x, scale, ff(6:-6:-1), fph) else if (data%hoppet_b_matching) then call hoppet_eval (xx, qq, ff_dbl(6:-6:-1)) ff = ff_dbl else call pdf_evolve (data%id, x, scale, ff(6:-6:-1)) end if end if else if (data%has_photon) then call pdf_evolve (data%id, x, scale, ff, fph) else if (data%hoppet_b_matching) then call hoppet_eval (xx, qq, ff_dbl) ff = ff_dbl else call pdf_evolve (data%id, x, scale, ff) end if end if end if if (data%has_photon) then allocate (fc (count ([data%mask, data%mask_photon]))) if (negative_sf_opt) then fc = pack ([ff, fph], [data%mask, data%mask_photon]) else fc = max( pack ([ff, fph], [data%mask, data%mask_photon]), 0._default) end if else allocate (fc (count (data%mask))) if (negative_sf_opt) then fc = pack (ff, data%mask) else fc = max( pack (ff, data%mask), 0._default) end if end if end associate if (debug_active (D_BEAMS)) print *, 'Set pdfs: ', real (fc) call sf_int%set_matrix_element (fc, [(i_sub_opt * size(fc) + i, i = 1, size(fc))]) sf_int%status = SF_EVALUATED end subroutine pdf_builtin_apply @ %def pdf_builtin_apply @ \subsection{Strong Coupling} Since the PDF codes provide a function for computing the running $\alpha_s$ value, we make this available as an implementation of the abstract [[alpha_qcd_t]] type, which is used for matrix element evaluation. <>= public :: alpha_qcd_pdf_builtin_t <>= type, extends (alpha_qcd_t) :: alpha_qcd_pdf_builtin_t type(string_t) :: pdfset_name integer :: pdfset_id = -1 contains <> end type alpha_qcd_pdf_builtin_t @ %def alpha_qcd_pdf_builtin_t @ Output. <>= procedure :: write => alpha_qcd_pdf_builtin_write <>= module subroutine alpha_qcd_pdf_builtin_write (object, unit) class(alpha_qcd_pdf_builtin_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine alpha_qcd_pdf_builtin_write <>= module subroutine alpha_qcd_pdf_builtin_write (object, unit) class(alpha_qcd_pdf_builtin_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A)") "QCD parameters (pdf_builtin):" write (u, "(5x,A,A)") "PDF set = ", char (object%pdfset_name) write (u, "(5x,A,I0)") "PDF ID = ", object%pdfset_id end subroutine alpha_qcd_pdf_builtin_write @ %def alpha_qcd_pdf_builtin_write @ Calculation: the numeric ID selects the correct PDF set, which must be properly initialized. <>= procedure :: get => alpha_qcd_pdf_builtin_get <>= module function alpha_qcd_pdf_builtin_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_pdf_builtin_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha end function alpha_qcd_pdf_builtin_get <>= module function alpha_qcd_pdf_builtin_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_pdf_builtin_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha alpha = pdf_alphas (alpha_qcd%pdfset_id, scale) end function alpha_qcd_pdf_builtin_get @ %def alpha_qcd_pdf_builtin_get @ Initialization. We need to access the global initialization status. <>= procedure :: init => alpha_qcd_pdf_builtin_init <>= module subroutine alpha_qcd_pdf_builtin_init (alpha_qcd, name, path) class(alpha_qcd_pdf_builtin_t), intent(out) :: alpha_qcd type(string_t), intent(in) :: name type(string_t), intent(in) :: path end subroutine alpha_qcd_pdf_builtin_init <>= module subroutine alpha_qcd_pdf_builtin_init (alpha_qcd, name, path) class(alpha_qcd_pdf_builtin_t), intent(out) :: alpha_qcd type(string_t), intent(in) :: name type(string_t), intent(in) :: path alpha_qcd%pdfset_name = name alpha_qcd%pdfset_id = pdf_get_id (name) if (alpha_qcd%pdfset_id < 0) & call msg_fatal ("QCD parameter initialization: PDF set " & // char (name) // " is unknown") call pdf_init (alpha_qcd%pdfset_id, path) end subroutine alpha_qcd_pdf_builtin_init @ %def alpha_qcd_pdf_builtin_init @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_pdf_builtin_ut.f90]]>>= <> module sf_pdf_builtin_ut use unit_tests use sf_pdf_builtin_uti <> <> contains <> end module sf_pdf_builtin_ut @ %def sf_pdf_builtin_ut @ <<[[sf_pdf_builtin_uti.f90]]>>= <> module sf_pdf_builtin_uti <> <> use os_interface use physics_defs, only: PROTON use sm_qcd use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use sf_base use sf_pdf_builtin <> <> contains <> end module sf_pdf_builtin_uti @ %def sf_pdf_builtin_ut @ API: driver for the unit tests below. <>= public :: sf_pdf_builtin_test <>= subroutine sf_pdf_builtin_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_pdf_builtin_test @ %def sf_pdf_builtin_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_pdf_builtin_1, "sf_pdf_builtin_1", & "structure function configuration", & u, results) <>= public :: sf_pdf_builtin_1 <>= subroutine sf_pdf_builtin_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data type(string_t) :: name write (u, "(A)") "* Test output: sf_pdf_builtin_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call os_data%init () call model%init_sm_test () pdg_in = PROTON allocate (pdf_builtin_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") name = "CTEQ6L" select type (data) type is (pdf_builtin_data_t) call data%init (model, pdg_in, name, & os_data%pdf_builtin_datapath) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_pdf_builtin_1" end subroutine sf_pdf_builtin_1 @ %def sf_pdf_builtin_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the PDF builtin structure function. <>= call test (sf_pdf_builtin_2, "sf_pdf_builtin_2", & "structure function instance", & u, results) <>= public :: sf_pdf_builtin_2 <>= subroutine sf_pdf_builtin_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(string_t) :: name type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_pdf_builtin_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call os_data%init () call model%init_sm_test () call flv%init (PROTON, model) pdg_in = PROTON call reset_interaction_counter () name = "CTEQ6L" allocate (pdf_builtin_data_t :: data) select type (data) type is (pdf_builtin_data_t) call data%init (model, pdg_in, name, & os_data%pdf_builtin_datapath) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.5_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Evaluate for Q = 100 GeV" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_pdf_builtin_2" end subroutine sf_pdf_builtin_2 @ %def sf_pdf_builtin_2 @ \subsubsection{Strong Coupling} Test $\alpha_s$ as an implementation of the [[alpha_qcd_t]] abstract type. <>= call test (sf_pdf_builtin_3, "sf_pdf_builtin_3", & "running alpha_s", & u, results) <>= public :: sf_pdf_builtin_3 <>= subroutine sf_pdf_builtin_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(qcd_t) :: qcd type(string_t) :: name write (u, "(A)") "* Test output: sf_pdf_builtin_3" write (u, "(A)") "* Purpose: initialize and evaluate alpha_s" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call os_data%init () name = "CTEQ6L" write (u, "(A)") "* Initialize qcd object" write (u, "(A)") allocate (alpha_qcd_pdf_builtin_t :: qcd%alpha) select type (alpha => qcd%alpha) type is (alpha_qcd_pdf_builtin_t) call alpha%init (name, os_data%pdf_builtin_datapath) end select call qcd%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for Q = 100" write (u, "(A)") write (u, "(1x,A,F8.5)") "alpha = ", qcd%alpha%get (100._default) write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") write (u, "(A)") "* Test output end: sf_pdf_builtin_3" end subroutine sf_pdf_builtin_3 @ %def sf_pdf_builtin_3 @ \clearpage %------------------------------------------------------------------------ \section{LHAPDF} Parton distribution functions (PDFs) are available via an interface to the LHAPDF standard library. @ \subsection{The module} <<[[sf_lhapdf.f90]]>>= <> module sf_lhapdf <> <> use sm_qcd use pdg_arrays use model_data use flavors use polarizations use sf_base use lhapdf !NODEP! <> <> <> <> <> interface <> end interface contains <> end module sf_lhapdf @ %def sf_lhapdf @ <<[[sf_lhapdf_sub.f90]]>>= <> submodule (sf_lhapdf) sf_lhapdf_s use format_defs, only: FMT_17, FMT_19 use io_units use system_dependencies, only: LHAPDF_PDFSETS_PATH use system_dependencies, only: LHAPDF5_AVAILABLE use system_dependencies, only: LHAPDF6_AVAILABLE use diagnostics use physics_defs, only: PROTON, PHOTON, PIPLUS, GLUON use physics_defs, only: HADRON_REMNANT_SINGLET use physics_defs, only: HADRON_REMNANT_TRIPLET use physics_defs, only: HADRON_REMNANT_OCTET use lorentz use colors use quantum_numbers use state_matrices use hoppet_interface implicit none <> contains <> end submodule sf_lhapdf_s @ %def sf_lhapdf_s @ \subsection{Codes for default PDF sets} The default PDF for protons set is chosen to be CTEQ6ll (LO fit with LO $\alpha_s$). <>= character(*), parameter :: LHAPDF5_DEFAULT_PROTON = "cteq6ll.LHpdf" character(*), parameter :: LHAPDF5_DEFAULT_PION = "ABFKWPI.LHgrid" character(*), parameter :: LHAPDF5_DEFAULT_PHOTON = "GSG960.LHgrid" character(*), parameter :: LHAPDF6_DEFAULT_PROTON = "CT10" @ %def LHAPDF5_DEFAULT_PROTON LHAPDF5_DEFAULT_PION @ %def LHAPDF5_DEFAULT_PHOTON LHAPDF6_DEFAULT_PROTON @ \subsection{LHAPDF library interface} Here we specify explicit interfaces for all LHAPDF routines that we use below. <>= interface subroutine InitPDFsetM (set, file) integer, intent(in) :: set character(*), intent(in) :: file end subroutine InitPDFsetM end interface @ %def InitPDFsetM <>= interface subroutine InitPDFM (set, mem) integer, intent(in) :: set, mem end subroutine InitPDFM end interface @ %def InitPDFM <>= interface subroutine numberPDFM (set, n_members) integer, intent(in) :: set integer, intent(out) :: n_members end subroutine numberPDFM end interface @ %def numberPDFM <>= interface subroutine evolvePDFM (set, x, q, ff) integer, intent(in) :: set double precision, intent(in) :: x, q double precision, dimension(-6:6), intent(out) :: ff end subroutine evolvePDFM end interface @ %def evolvePDFM <>= interface subroutine evolvePDFphotonM (set, x, q, ff, fphot) integer, intent(in) :: set double precision, intent(in) :: x, q double precision, dimension(-6:6), intent(out) :: ff double precision, intent(out) :: fphot end subroutine evolvePDFphotonM end interface @ %def evolvePDFphotonM <>= interface subroutine evolvePDFpM (set, x, q, s, scheme, ff) integer, intent(in) :: set double precision, intent(in) :: x, q, s integer, intent(in) :: scheme double precision, dimension(-6:6), intent(out) :: ff end subroutine evolvePDFpM end interface @ %def evolvePDFpM <>= interface subroutine GetXminM (set, mem, xmin) integer, intent(in) :: set, mem double precision, intent(out) :: xmin end subroutine GetXminM end interface @ %def GetXminM <>= interface subroutine GetXmaxM (set, mem, xmax) integer, intent(in) :: set, mem double precision, intent(out) :: xmax end subroutine GetXmaxM end interface @ %def GetXmaxM <>= interface subroutine GetQ2minM (set, mem, q2min) integer, intent(in) :: set, mem double precision, intent(out) :: q2min end subroutine GetQ2minM end interface @ %def GetQ2minM <>= interface subroutine GetQ2maxM (set, mem, q2max) integer, intent(in) :: set, mem double precision, intent(out) :: q2max end subroutine GetQ2maxM end interface @ %def GetQ2maxM <>= interface function has_photon () result(flag) logical :: flag end function has_photon end interface @ %def has_photon @ \subsection{The LHAPDF status} This type holds the initialization status of the LHAPDF system. Entry 1 is for proton PDFs, entry 2 for pion PDFs, entry 3 for photon PDFs. Since it is connected to the external LHAPDF library, this is a truly global object. We implement it as a a private module variable. To access it from elsewhere, the caller has to create and initialize an object of type [[lhapdf_status_t]], which acts as a proxy. <>= type :: lhapdf_global_status_t private logical, dimension(3) :: initialized = .false. end type lhapdf_global_status_t @ %def lhapdf_global_status_t <>= type(lhapdf_global_status_t), save :: lhapdf_global_status @ %def lhapdf_global_status <>= function lhapdf_global_status_is_initialized (set) result (flag) logical :: flag integer, intent(in), optional :: set if (present (set)) then select case (set) case (1:3); flag = lhapdf_global_status%initialized(set) case default; flag = .false. end select else flag = any (lhapdf_global_status%initialized) end if end function lhapdf_global_status_is_initialized @ %def lhapdf_global_status_is_initialized <>= subroutine lhapdf_global_status_set_initialized (set) integer, intent(in) :: set lhapdf_global_status%initialized(set) = .true. end subroutine lhapdf_global_status_set_initialized @ %def lhapdf_global_status_set_initialized @ This is the only public procedure, it tells the system to forget about previous initialization, allowing for changing the chosen PDF set. Note that such a feature works only if the global program flow is serial, so no two distinct sets are accessed simultaneously. But this applies to LHAPDF anyway. <>= public :: lhapdf_global_reset <>= module subroutine lhapdf_global_reset () end subroutine lhapdf_global_reset <>= module subroutine lhapdf_global_reset () lhapdf_global_status%initialized = .false. end subroutine lhapdf_global_reset @ %def lhapdf_global_status_reset @ \subsection{LHAPDF initialization} Before using LHAPDF, we have to initialize it with a particular data set and member. This applies not just if we use structure functions, but also if we just use an $\alpha_s$ formula. The integer [[set]] should be $1$ for proton, $2$ for pion, and $3$ for photon, but this is just convention. It appears as if LHAPDF does not allow for multiple data sets being used concurrently (?), so multi-threaded usage with different sets (e.g., a scan) is excluded. The current setup with a global flag that indicates initialization is fine as long as Whizard itself is run in serial mode at the Sindarin level. If we introduce multithreading in any form from Sindarin, we have to rethink the implementation of the LHAPDF interface. (The same considerations apply to builtin PDFs.) If the particular set has already been initialized, do nothing. This implies that whenever we want to change the setup for a particular set, we have to reset the LHAPDF status. [[lhapdf_initialize]] has an obvious name clash with [[lhapdf_init]], the reason it works for [[pdf_builtin]] is that there things are outsourced to a separate module (inc. [[lhapdf_status]] etc.). <>= public :: lhapdf_initialize <>= module subroutine lhapdf_initialize & (set, prefix, file, member, pdf, b_match) integer, intent(in) :: set type(string_t), intent(inout) :: prefix type(string_t), intent(inout) :: file type(lhapdf_pdf_t), intent(inout), optional :: pdf integer, intent(inout) :: member logical, intent(in), optional :: b_match end subroutine lhapdf_initialize <>= module subroutine lhapdf_initialize & (set, prefix, file, member, pdf, b_match) integer, intent(in) :: set type(string_t), intent(inout) :: prefix type(string_t), intent(inout) :: file type(lhapdf_pdf_t), intent(inout), optional :: pdf integer, intent(inout) :: member logical, intent(in), optional :: b_match if (prefix == "") prefix = LHAPDF_PDFSETS_PATH if (LHAPDF5_AVAILABLE) then if (lhapdf_global_status_is_initialized (set)) return if (file == "") then select case (set) case (1); file = LHAPDF5_DEFAULT_PROTON case (2); file = LHAPDF5_DEFAULT_PION case (3); file = LHAPDF5_DEFAULT_PHOTON end select end if if (data_file_exists (prefix // "/" // file)) then call InitPDFsetM (set, char (prefix // "/" // file)) else call msg_fatal ("LHAPDF: Data file '" & // char (file) // "' not found in '" // char (prefix) // "'.") return end if if (.not. dataset_member_exists (set, member)) then call msg_error (" LHAPDF: Chosen member does not exist for set '" & // char (file) // "', using default.") member = 0 end if call InitPDFM (set, member) else if (LHAPDF6_AVAILABLE) then ! TODO: (bcn 2015-07-07) we should have a closer look why this global ! check must not be executed ! if (lhapdf_global_status_is_initialized (set) .and. & ! pdf%is_associated ()) return if (file == "") then select case (set) case (1); file = LHAPDF6_DEFAULT_PROTON case (2); call msg_fatal ("LHAPDF6: no pion PDFs supported") case (3); call msg_fatal ("LHAPDF6: no photon PDFs supported") end select end if if (data_file_exists (prefix // "/" // file // "/" // file // ".info")) then call pdf%init (char (file), member) else call msg_fatal ("LHAPDF: Data file '" & // char (file) // "' not found in '" // char (prefix) // "'.") return end if end if if (present (b_match)) then if (b_match) then if (LHAPDF5_AVAILABLE) then call hoppet_init (.false.) else if (LHAPDF6_AVAILABLE) then call hoppet_init (.false., pdf) end if end if end if call lhapdf_global_status_set_initialized (set) contains function data_file_exists (fq_name) result (exist) type(string_t), intent(in) :: fq_name logical :: exist inquire (file = char(fq_name), exist = exist) end function data_file_exists function dataset_member_exists (set, member) result (exist) integer, intent(in) :: set, member logical :: exist integer :: n_members call numberPDFM (set, n_members) exist = member >= 0 .and. member <= n_members end function dataset_member_exists end subroutine lhapdf_initialize @ %def lhapdf_initialize @ \subsection{Kinematics} Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, we are asked to provide an efficient mapping. For the test case, we set $x=r^2$ and consequently $f(r)=2r$. <>= procedure :: complete_kinematics => lhapdf_complete_kinematics <>= module subroutine lhapdf_complete_kinematics & (sf_int, x, xb, f, r, rb, map) class(lhapdf_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map end subroutine lhapdf_complete_kinematics <>= module subroutine lhapdf_complete_kinematics & (sf_int, x, xb, f, r, rb, map) class(lhapdf_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("LHAPDF: map flag not supported") else x(1) = r(1) xb(1)= rb(1) f = 1 end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_DONE_KINEMATICS) sf_int%x = x(1) case (SF_FAILED_KINEMATICS) sf_int%x = 0 f = 0 end select end subroutine lhapdf_complete_kinematics @ %def lhapdf_complete_kinematics @ Overriding the default method: we compute the [[x]] value from the momentum configuration. In this specific case, we also set the internally stored $x$ value, so it can be used in the following routine. <>= procedure :: recover_x => lhapdf_recover_x <>= module subroutine lhapdf_recover_x (sf_int, x, xb, x_free) class(lhapdf_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free end subroutine lhapdf_recover_x <>= module subroutine lhapdf_recover_x (sf_int, x, xb, x_free) class(lhapdf_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) end subroutine lhapdf_recover_x @ %def lhapdf_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => lhapdf_inverse_kinematics <>= module subroutine lhapdf_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(lhapdf_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta end subroutine lhapdf_inverse_kinematics <>= module subroutine lhapdf_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(lhapdf_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("LHAPDF: map flag not supported") else r(1) = x(1) rb(1)= xb(1) f = 1 end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine lhapdf_inverse_kinematics @ %def lhapdf_inverse_kinematics @ \subsection{The LHAPDF data block} The data block holds the incoming flavor (which has to be proton, pion, or photon), the corresponding pointer to the global access data (1, 2, or 3), the flag [[invert]] which is set for an antiproton, the bounds as returned by LHAPDF for the specified set, and a mask that determines which partons will be actually in use. <>= public :: lhapdf_data_t <>= type, extends (sf_data_t) :: lhapdf_data_t private type(string_t) :: prefix type(string_t) :: file type(lhapdf_pdf_t) :: pdf integer :: member = 0 class(model_data_t), pointer :: model => null () type(flavor_t) :: flv_in integer :: set = 0 logical :: invert = .false. logical :: photon = .false. logical :: has_photon = .false. integer :: photon_scheme = 0 real(default) :: xmin = 0, xmax = 0 real(default) :: qmin = 0, qmax = 0 logical, dimension(-6:6) :: mask = .true. logical :: mask_photon = .true. logical :: hoppet_b_matching = .false. contains <> end type lhapdf_data_t @ %def lhapdf_data_t @ Generate PDF data. This is provided as a function, but it has the side-effect of initializing the requested PDF set. A finalizer is not needed. The library uses double precision, so since the default precision may be extended or quadruple, we use auxiliary variables for type casting. <>= procedure :: init => lhapdf_data_init <>= module subroutine lhapdf_data_init & (data, model, pdg_in, prefix, file, member, photon_scheme, & hoppet_b_matching) class(lhapdf_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in type(string_t), intent(in), optional :: prefix, file integer, intent(in), optional :: member integer, intent(in), optional :: photon_scheme logical, intent(in), optional :: hoppet_b_matching end subroutine lhapdf_data_init <>= module subroutine lhapdf_data_init & (data, model, pdg_in, prefix, file, member, photon_scheme, & hoppet_b_matching) class(lhapdf_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in type(string_t), intent(in), optional :: prefix, file integer, intent(in), optional :: member integer, intent(in), optional :: photon_scheme logical, intent(in), optional :: hoppet_b_matching double precision :: xmin, xmax, q2min, q2max external :: InitPDFsetM, InitPDFM, numberPDFM external :: GetXminM, GetXmaxM, GetQ2minM, GetQ2maxM if (.not. LHAPDF5_AVAILABLE .and. .not. LHAPDF6_AVAILABLE) then call msg_fatal ("LHAPDF requested but library is not linked") return end if data%model => model if (pdg_in%get_length () /= 1) & call msg_fatal ("PDF: incoming particle must be unique") call data%flv_in%init (pdg_in%get (1), model) select case (pdg_in%get (1)) case (PROTON) data%set = 1 case (-PROTON) data%set = 1 data%invert = .true. case (PIPLUS) data%set = 2 case (-PIPLUS) data%set = 2 data%invert = .true. case (PHOTON) data%set = 3 data%photon = .true. if (present (photon_scheme)) data%photon_scheme = photon_scheme case default call msg_fatal (" LHAPDF: " & // "incoming particle must be (anti)proton, pion, or photon.") return end select if (present (prefix)) then data%prefix = prefix else data%prefix = "" end if if (present (file)) then data%file = file else data%file = "" end if if (present (hoppet_b_matching)) data%hoppet_b_matching = hoppet_b_matching if (LHAPDF5_AVAILABLE) then call lhapdf_initialize (data%set, & data%prefix, data%file, data%member, & b_match = data%hoppet_b_matching) call GetXminM (data%set, data%member, xmin) call GetXmaxM (data%set, data%member, xmax) call GetQ2minM (data%set, data%member, q2min) call GetQ2maxM (data%set, data%member, q2max) data%xmin = xmin data%xmax = xmax data%qmin = sqrt (q2min) data%qmax = sqrt (q2max) data%has_photon = has_photon () else if (LHAPDF6_AVAILABLE) then call lhapdf_initialize (data%set, & data%prefix, data%file, data%member, & data%pdf, data%hoppet_b_matching) data%xmin = data%pdf%getxmin () data%xmax = data%pdf%getxmax () data%qmin = sqrt(data%pdf%getq2min ()) data%qmax = sqrt(data%pdf%getq2max ()) data%has_photon = data%pdf%has_photon () end if end subroutine lhapdf_data_init @ %def lhapdf_data_init @ Enable/disable partons explicitly. If a mask entry is true, applying the PDF will generate the corresponding flavor on output. <>= procedure :: set_mask => lhapdf_data_set_mask <>= subroutine lhapdf_data_set_mask (data, mask) class(lhapdf_data_t), intent(inout) :: data logical, dimension(-6:6), intent(in) :: mask data%mask = mask end subroutine lhapdf_data_set_mask @ %def lhapdf_data_set_mask @ Return the public part of the data set. <>= public :: lhapdf_data_get_public_info <>= subroutine lhapdf_data_get_public_info & (data, lhapdf_dir, lhapdf_file, lhapdf_member) type(lhapdf_data_t), intent(in) :: data type(string_t), intent(out) :: lhapdf_dir, lhapdf_file integer, intent(out) :: lhapdf_member lhapdf_dir = data%prefix lhapdf_file = data%file lhapdf_member = data%member end subroutine lhapdf_data_get_public_info @ %def lhapdf_data_get_public_info @ Return the number of the member of the data set. <>= public :: lhapdf_data_get_set <>= function lhapdf_data_get_set(data) result(set) type(lhapdf_data_t), intent(in) :: data integer :: set set = data%set end function lhapdf_data_get_set @ %def lhapdf_data_get_set @ Output <>= procedure :: write => lhapdf_data_write <>= module subroutine lhapdf_data_write (data, unit, verbose) class(lhapdf_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine lhapdf_data_write <>= module subroutine lhapdf_data_write (data, unit, verbose) class(lhapdf_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose logical :: verb integer :: u if (present (verbose)) then verb = verbose else verb = .false. end if u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "LHAPDF data:" if (data%set /= 0) then write (u, "(3x,A)", advance="no") "flavor = " call data%flv_in%write (u); write (u, *) if (verb) then write (u, "(3x,A,A)") " prefix = ", char (data%prefix) else write (u, "(3x,A,A)") " prefix = ", & " " end if write (u, "(3x,A,A)") " file = ", char (data%file) write (u, "(3x,A,I3)") " member = ", data%member write (u, "(3x,A," // FMT_19 // ")") " x(min) = ", data%xmin write (u, "(3x,A," // FMT_19 // ")") " x(max) = ", data%xmax write (u, "(3x,A," // FMT_19 // ")") " Q(min) = ", data%qmin write (u, "(3x,A," // FMT_19 // ")") " Q(max) = ", data%qmax write (u, "(3x,A,L1)") " invert = ", data%invert if (data%photon) write (u, "(3x,A,I3)") & " IP2 (scheme) = ", data%photon_scheme write (u, "(3x,A,6(1x,L1),1x,A,1x,L1,1x,A,6(1x,L1))") & " mask = ", & data%mask(-6:-1), "*", data%mask(0), "*", data%mask(1:6) write (u, "(3x,A,L1)") " photon mask = ", data%mask_photon if (data%set == 1) write (u, "(3x,A,L1)") & " hoppet_b = ", data%hoppet_b_matching else write (u, "(3x,A)") "[undefined]" end if end subroutine lhapdf_data_write @ %def lhapdf_data_write @ The number of parameters is one. We do not generate transverse momentum. <>= procedure :: get_n_par => lhapdf_data_get_n_par <>= module function lhapdf_data_get_n_par (data) result (n) class(lhapdf_data_t), intent(in) :: data integer :: n end function lhapdf_data_get_n_par <>= module function lhapdf_data_get_n_par (data) result (n) class(lhapdf_data_t), intent(in) :: data integer :: n n = 1 end function lhapdf_data_get_n_par @ %def lhapdf_data_get_n_par @ Return the outgoing particle PDG codes. This is based on the mask. <>= procedure :: get_pdg_out => lhapdf_data_get_pdg_out <>= module subroutine lhapdf_data_get_pdg_out (data, pdg_out) class(lhapdf_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out end subroutine lhapdf_data_get_pdg_out <>= module subroutine lhapdf_data_get_pdg_out (data, pdg_out) class(lhapdf_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer, dimension(:), allocatable :: pdg1 integer :: n, np, i n = count (data%mask) np = 0; if (data%has_photon .and. data%mask_photon) np = 1 allocate (pdg1 (n + np)) pdg1(1:n) = pack ([(i, i = -6, 6)], data%mask) if (np == 1) pdg1(n+np) = PHOTON pdg_out(1) = pdg1 end subroutine lhapdf_data_get_pdg_out @ %def lhapdf_data_get_pdg_out @ Allocate the interaction record. Due to a gfortran 7/8/9 bug this has to remain in the main module. <>= procedure :: allocate_sf_int => lhapdf_data_allocate_sf_int <>= subroutine lhapdf_data_allocate_sf_int (data, sf_int) class(lhapdf_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (lhapdf_t :: sf_int) end subroutine lhapdf_data_allocate_sf_int @ %def lhapdf_data_allocate_sf_int @ Return the numerical PDF set index. <>= procedure :: get_pdf_set => lhapdf_data_get_pdf_set <>= elemental module function lhapdf_data_get_pdf_set (data) result (pdf_set) class(lhapdf_data_t), intent(in) :: data integer :: pdf_set end function lhapdf_data_get_pdf_set <>= elemental module function lhapdf_data_get_pdf_set (data) result (pdf_set) class(lhapdf_data_t), intent(in) :: data integer :: pdf_set pdf_set = data%set end function lhapdf_data_get_pdf_set @ %def lhapdf_data_get_pdf_set @ \subsection{The LHAPDF object} The [[lhapdf_t]] data type is a $1\to 2$ interaction which describes the splitting of an (anti)proton into a parton and a beam remnant. We stay in the strict forward-splitting limit, but allow some invariant mass for the beam remnant such that the outgoing parton is exactly massless. For a real event, we would replace this by a parton cascade, where the outgoing partons have virtuality as dictated by parton-shower kinematics, and transverse momentum is generated. This is the LHAPDF object which holds input data together with the interaction. We also store the $x$ momentum fraction and the scale, since kinematics and function value are requested at different times. The PDF application is a $1\to 2$ splitting process, where the particles are ordered as (hadron, remnant, parton). Polarization is ignored completely. The beam particle is colorless, while partons and beam remnant carry color. The remnant gets a special flavor code. <>= public :: lhapdf_t <>= type, extends (sf_int_t) :: lhapdf_t type(lhapdf_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: q = 0 real(default) :: s = 0 contains <> end type lhapdf_t @ %def lhapdf_t @ Type string: display the chosen PDF set. <>= procedure :: type_string => lhapdf_type_string <>= module function lhapdf_type_string (object) result (string) class(lhapdf_t), intent(in) :: object type(string_t) :: string end function lhapdf_type_string <>= module function lhapdf_type_string (object) result (string) class(lhapdf_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "LHAPDF: " // object%data%file else string = "LHAPDF: [undefined]" end if end function lhapdf_type_string @ %def lhapdf_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => lhapdf_write <>= module subroutine lhapdf_write (object, unit, testflag) class(lhapdf_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine lhapdf_write <>= module subroutine lhapdf_write (object, unit, testflag) class(lhapdf_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_17 // ")") "x =", object%x if (object%status >= SF_FAILED_EVALUATION) then write (u, "(3x,A," // FMT_17 // ")") "Q =", object%q end if end if call object%base_write (u, testflag) else write (u, "(1x,A)") "LHAPDF data: [undefined]" end if end subroutine lhapdf_write @ %def lhapdf_write @ Initialize. We know that [[data]] will be of concrete type [[sf_lhapdf_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass, but keep the radiated mass zero. <>= procedure :: init => lhapdf_init <>= module subroutine lhapdf_init (sf_int, data) class(lhapdf_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data end subroutine lhapdf_init <>= module subroutine lhapdf_init (sf_int, data) class(lhapdf_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask type(flavor_t) :: flv, flv_remnant type(color_t) :: col0 type(quantum_numbers_t), dimension(3) :: qn integer :: i select type (data) type is (lhapdf_data_t) mask = quantum_numbers_mask (.false., .false., .true.) call col0%init () call sf_int%base_init (mask, [0._default], [0._default], [0._default]) sf_int%data => data do i = -6, 6 if (data%mask(i)) then call qn(1)%init (data%flv_in, col = col0) if (i == 0) then call flv%init (GLUON, data%model) call flv_remnant%init (HADRON_REMNANT_OCTET, data%model) else call flv%init (i, data%model) call flv_remnant%init & (sign (HADRON_REMNANT_TRIPLET, -i), data%model) end if call qn(2)%init ( & flv = flv_remnant, col = color_from_flavor (flv_remnant, 1)) call qn(2)%tag_radiated () call qn(3)%init ( & flv = flv, col = color_from_flavor (flv, 1, reverse=.true.)) call sf_int%add_state (qn) end if end do if (data%has_photon .and. data%mask_photon) then call flv%init (PHOTON, data%model) call flv_remnant%init (HADRON_REMNANT_SINGLET, data%model) call qn(2)%init (flv = flv_remnant, & col = color_from_flavor (flv_remnant, 1)) call qn(2)%tag_radiated () call qn(3)%init (flv = flv, & col = color_from_flavor (flv, 1, reverse=.true.)) call sf_int%add_state (qn) end if call sf_int%freeze () call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) sf_int%status = SF_INITIAL end select end subroutine lhapdf_init @ %def lhapdf_init @ \subsection{Structure function} We have to cast the LHAPDF arguments to/from double precision (possibly from/to extended/quadruple precision), if necessary. Some structure functions can yield negative results (sea quarks close to $x=1$). In an NLO computation, this is perfectly fine and we keep negative values. Unlike total cross sections, PDFs do not have to be positive definite. For LO however, negative PDFs would cause negative event weights so we set these values to zero instead. <>= procedure :: apply => lhapdf_apply <>= module subroutine lhapdf_apply & (sf_int, scale, negative_sf, rescale, i_sub) class(lhapdf_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub end subroutine lhapdf_apply <>= module subroutine lhapdf_apply & (sf_int, scale, negative_sf, rescale, i_sub) class(lhapdf_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: x, s double precision :: xx, qq, ss double precision, dimension(-6:6) :: ff double precision :: fphot complex(default), dimension(:), allocatable :: fc integer :: i, i_sub_opt, j_sub logical :: negative_sf_opt external :: evolvePDFM, evolvePDFpM i_sub_opt = 0; if (present (i_sub)) i_sub_opt = i_sub negative_sf_opt = .false.; if (present(negative_sf)) negative_sf_opt = negative_sf associate (data => sf_int%data) sf_int%q = scale x = sf_int%x if (present (rescale)) call rescale%apply (x) s = sf_int%s xx = x if (debug2_active (D_BEAMS)) then call msg_debug2 (D_BEAMS, "lhapdf_apply") call msg_debug2 (D_BEAMS, "rescale: ", present(rescale)) call msg_debug2 (D_BEAMS, "i_sub: ", i_sub_opt) call msg_debug2 (D_BEAMS, "x: ", x) end if qq = min (data%qmax, scale) qq = max (data%qmin, qq) if (.not. data%photon) then if (data%invert) then if (data%has_photon) then if (LHAPDF5_AVAILABLE) then call evolvePDFphotonM & (data%set, xx, qq, ff(6:-6:-1), fphot) else if (LHAPDF6_AVAILABLE) then call data%pdf%evolve_pdfphotonm & (xx, qq, ff(6:-6:-1), fphot) end if else if (data%hoppet_b_matching) then call hoppet_eval (xx, qq, ff(6:-6:-1)) else if (LHAPDF5_AVAILABLE) then call evolvePDFM (data%set, xx, qq, ff(6:-6:-1)) else if (LHAPDF6_AVAILABLE) then call data%pdf%evolve_pdfm (xx, qq, ff(6:-6:-1)) end if end if end if else if (data%has_photon) then if (LHAPDF5_AVAILABLE) then call evolvePDFphotonM (data%set, xx, qq, ff, fphot) else if (LHAPDF6_AVAILABLE) then call data%pdf%evolve_pdfphotonm (xx, qq, ff, fphot) end if else if (data%hoppet_b_matching) then call hoppet_eval (xx, qq, ff) else if (LHAPDF5_AVAILABLE) then call evolvePDFM (data%set, xx, qq, ff) else if (LHAPDF6_AVAILABLE) then call data%pdf%evolve_pdfm (xx, qq, ff) end if end if end if end if else ss = s if (LHAPDF5_AVAILABLE) then call evolvePDFpM (data%set, xx, qq, & ss, data%photon_scheme, ff) else if (LHAPDF6_AVAILABLE) then call data%pdf%evolve_pdfpm (xx, qq, ss, & data%photon_scheme, ff) end if end if if (data%has_photon) then allocate (fc (count ([data%mask, data%mask_photon]))) if (negative_sf_opt) then fc = pack ([ff, fphot] / x, [data%mask, data%mask_photon]) else fc = max( pack ([ff, fphot] / x, [data%mask, data%mask_photon]), 0._default) end if else allocate (fc (count (data%mask))) if (negative_sf_opt) then fc = pack (ff / x, data%mask) else fc = max( pack (ff / x, data%mask), 0._default) end if end if end associate if (debug_active (D_BEAMS)) print *, 'Set pdfs: ', real (fc) call sf_int%set_matrix_element (fc, [(i_sub_opt * size(fc) + i, i = 1, size(fc))]) sf_int%status = SF_EVALUATED end subroutine lhapdf_apply @ %def apply_lhapdf @ \subsection{Strong Coupling} Since the PDF codes provide a function for computing the running $\alpha_s$ value, we make this available as an implementation of the abstract [[alpha_qcd_t]] type, which is used for matrix element evaluation. <>= public :: alpha_qcd_lhapdf_t <>= type, extends (alpha_qcd_t) :: alpha_qcd_lhapdf_t type(string_t) :: pdfset_dir type(string_t) :: pdfset_file integer :: pdfset_member = -1 type(lhapdf_pdf_t) :: pdf contains <> end type alpha_qcd_lhapdf_t @ %def alpha_qcd_lhapdf_t @ Output. As in earlier versions we leave the LHAPDF path out. <>= procedure :: write => alpha_qcd_lhapdf_write <>= module subroutine alpha_qcd_lhapdf_write (object, unit) class(alpha_qcd_lhapdf_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine alpha_qcd_lhapdf_write <>= module subroutine alpha_qcd_lhapdf_write (object, unit) class(alpha_qcd_lhapdf_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A)") "QCD parameters (lhapdf):" write (u, "(5x,A,A)") "PDF set = ", char (object%pdfset_file) write (u, "(5x,A,I0)") "PDF member = ", object%pdfset_member end subroutine alpha_qcd_lhapdf_write @ %def alpha_qcd_lhapdf_write @ Calculation: the numeric member ID selects the correct PDF set, which must be properly initialized. <>= interface double precision function alphasPDF (Q) double precision, intent(in) :: Q end function alphasPDF end interface @ %def alphasPDF @ <>= procedure :: get => alpha_qcd_lhapdf_get <>= module function alpha_qcd_lhapdf_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_lhapdf_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha end function alpha_qcd_lhapdf_get <>= module function alpha_qcd_lhapdf_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_lhapdf_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha if (LHAPDF5_AVAILABLE) then alpha = alphasPDF (dble (scale)) else if (LHAPDF6_AVAILABLE) then alpha = alpha_qcd%pdf%alphas_pdf (dble (scale)) end if end function alpha_qcd_lhapdf_get @ %def alpha_qcd_lhapdf_get @ Initialization. We need to access the (quasi-global) initialization status. <>= procedure :: init => alpha_qcd_lhapdf_init <>= module subroutine alpha_qcd_lhapdf_init (alpha_qcd, file, member, path) class(alpha_qcd_lhapdf_t), intent(out) :: alpha_qcd type(string_t), intent(inout) :: file integer, intent(inout) :: member type(string_t), intent(inout) :: path end subroutine alpha_qcd_lhapdf_init <>= module subroutine alpha_qcd_lhapdf_init (alpha_qcd, file, member, path) class(alpha_qcd_lhapdf_t), intent(out) :: alpha_qcd type(string_t), intent(inout) :: file integer, intent(inout) :: member type(string_t), intent(inout) :: path alpha_qcd%pdfset_file = file alpha_qcd%pdfset_member = member if (alpha_qcd%pdfset_member < 0) & call msg_fatal ("QCD parameter initialization: PDF set " & // char (file) // " is unknown") if (LHAPDF5_AVAILABLE) then call lhapdf_initialize (1, path, file, member) else if (LHAPDF6_AVAILABLE) then call lhapdf_initialize & (1, path, file, member, alpha_qcd%pdf) end if end subroutine alpha_qcd_lhapdf_init @ %def alpha_qcd_lhapdf_init @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_lhapdf_ut.f90]]>>= <> module sf_lhapdf_ut use unit_tests use system_dependencies, only: LHAPDF5_AVAILABLE use system_dependencies, only: LHAPDF6_AVAILABLE use sf_lhapdf_uti <> <> contains <> end module sf_lhapdf_ut @ %def sf_lhapdf_ut @ <<[[sf_lhapdf_uti.f90]]>>= <> module sf_lhapdf_uti <> <> use system_dependencies, only: LHAPDF5_AVAILABLE use system_dependencies, only: LHAPDF6_AVAILABLE use os_interface use physics_defs, only: PROTON use sm_qcd use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use sf_base use sf_lhapdf <> <> contains <> end module sf_lhapdf_uti @ %def sf_lhapdf_ut @ API: driver for the unit tests below. <>= public :: sf_lhapdf_test <>= subroutine sf_lhapdf_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_lhapdf_test @ %def sf_lhapdf_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= if (LHAPDF5_AVAILABLE) then call test (sf_lhapdf_1, "sf_lhapdf5_1", & "structure function configuration", & u, results) else if (LHAPDF6_AVAILABLE) then call test (sf_lhapdf_1, "sf_lhapdf6_1", & "structure function configuration", & u, results) end if <>= public :: sf_lhapdf_1 <>= subroutine sf_lhapdf_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_lhapdf_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_sm_test () pdg_in = PROTON allocate (lhapdf_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") select type (data) type is (lhapdf_data_t) call data%init (model, pdg_in) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_lhapdf_1" end subroutine sf_lhapdf_1 @ %def sf_lhapdf_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the PDF builtin structure function. <>= if (LHAPDF5_AVAILABLE) then call test (sf_lhapdf_2, "sf_lhapdf5_2", & "structure function instance", & u, results) else if (LHAPDF6_AVAILABLE) then call test (sf_lhapdf_2, "sf_lhapdf6_2", & "structure function instance", & u, results) end if <>= public :: sf_lhapdf_2 <>= subroutine sf_lhapdf_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_lhapdf_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (PROTON, model) pdg_in = PROTON call lhapdf_global_reset () call reset_interaction_counter () allocate (lhapdf_data_t :: data) select type (data) type is (lhapdf_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.5_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Evaluate for Q = 100 GeV" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale = 100._default) call sf_int%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_lhapdf_2" end subroutine sf_lhapdf_2 @ %def sf_lhapdf_2 @ \subsubsection{Strong Coupling} Test $\alpha_s$ as an implementation of the [[alpha_qcd_t]] abstract type. <>= if (LHAPDF5_AVAILABLE) then call test (sf_lhapdf_3, "sf_lhapdf5_3", & "running alpha_s", & u, results) else if (LHAPDF6_AVAILABLE) then call test (sf_lhapdf_3, "sf_lhapdf6_3", & "running alpha_s", & u, results) end if <>= public :: sf_lhapdf_3 <>= subroutine sf_lhapdf_3 (u) integer, intent(in) :: u type(qcd_t) :: qcd type(string_t) :: name, path integer :: member write (u, "(A)") "* Test output: sf_lhapdf_3" write (u, "(A)") "* Purpose: initialize and evaluate alpha_s" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call lhapdf_global_reset () if (LHAPDF5_AVAILABLE) then name = "cteq6ll.LHpdf" member = 1 path = "" else if (LHAPDF6_AVAILABLE) then name = "CT10" member = 1 path = "" end if write (u, "(A)") "* Initialize qcd object" write (u, "(A)") allocate (alpha_qcd_lhapdf_t :: qcd%alpha) select type (alpha => qcd%alpha) type is (alpha_qcd_lhapdf_t) call alpha%init (name, member, path) end select call qcd%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for Q = 100" write (u, "(A)") write (u, "(1x,A,F8.5)") "alpha = ", qcd%alpha%get (100._default) write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") write (u, "(A)") "* Test output end: sf_lhapdf_3" end subroutine sf_lhapdf_3 @ %def sf_lhapdf_3 @ \section{Easy PDF Access} For the shower, subtraction and matching, it is very useful to have direct access to $f(x,Q)$ independently of the used library. <<[[pdf.f90]]>>= <> module pdf <> use beam_structures use lhapdf !NODEP! use pdf_builtin !NODEP! <> <> <> <> interface <> end interface end module pdf @ %def pdf @ <<[[pdf_sub.f90]]>>= <> submodule (pdf) pdf_s use io_units use system_dependencies, only: LHAPDF5_AVAILABLE, LHAPDF6_AVAILABLE use diagnostics implicit none contains <> end submodule pdf_s @ %def pdf_s @ We support the following implementations: <>= integer, parameter, public :: STRF_NONE = 0 integer, parameter, public :: STRF_LHAPDF6 = 1 integer, parameter, public :: STRF_LHAPDF5 = 2 integer, parameter, public :: STRF_PDF_BUILTIN = 3 @ %def STRF_NONE STRF_LHAPDF6 STRF_LHAPDF5 STRF_PDF_BUILTIN @ A container to bundle all necessary PDF data. Could be moved to a more central location. <>= public :: pdf_data_t <>= type :: pdf_data_t type(lhapdf_pdf_t) :: pdf real(default) :: xmin, xmax, qmin, qmax integer :: type = STRF_NONE integer :: set = 0 contains <> end type pdf_data_t @ %def pdf_data @ <>= procedure :: init => pdf_data_init <>= module subroutine pdf_data_init (pdf_data, pdf_data_in) class(pdf_data_t), intent(out) :: pdf_data type(pdf_data_t), target, intent(in) :: pdf_data_in end subroutine pdf_data_init <>= module subroutine pdf_data_init (pdf_data, pdf_data_in) class(pdf_data_t), intent(out) :: pdf_data type(pdf_data_t), target, intent(in) :: pdf_data_in pdf_data%xmin = pdf_data_in%xmin pdf_data%xmax = pdf_data_in%xmax pdf_data%qmin = pdf_data_in%qmin pdf_data%qmax = pdf_data_in%qmax pdf_data%set = pdf_data_in%set pdf_data%type = pdf_data_in%type if (pdf_data%type == STRF_LHAPDF6) then if (pdf_data_in%pdf%is_associated ()) then call lhapdf_copy_pointer (pdf_data_in%pdf, pdf_data%pdf) else call msg_bug ('pdf_data_init: pdf_data%pdf was not associated!') end if end if end subroutine pdf_data_init @ %def pdf_data_init @ <>= procedure :: write => pdf_data_write <>= module subroutine pdf_data_write (pdf_data, unit) class(pdf_data_t), intent(in) :: pdf_data integer, intent(in), optional :: unit end subroutine pdf_data_write <>= module subroutine pdf_data_write (pdf_data, unit) class(pdf_data_t), intent(in) :: pdf_data integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(3x,A,I0)") "PDF set = ", pdf_data%set write (u, "(3x,A,I0)") "PDF type = ", pdf_data%type end subroutine pdf_data_write @ %def pdf_data_write @ <>= procedure :: setup => pdf_data_setup <>= module subroutine pdf_data_setup & (pdf_data, caller, beam_structure, lhapdf_member, set) class(pdf_data_t), intent(inout) :: pdf_data character(len=*), intent(in) :: caller type(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: lhapdf_member, set end subroutine pdf_data_setup <>= module subroutine pdf_data_setup & (pdf_data, caller, beam_structure, lhapdf_member, set) class(pdf_data_t), intent(inout) :: pdf_data character(len=*), intent(in) :: caller type(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: lhapdf_member, set real(default) :: xmin, xmax, q2min, q2max pdf_data%set = set if (beam_structure%contains ("lhapdf")) then if (LHAPDF6_AVAILABLE) then pdf_data%type = STRF_LHAPDF6 else if (LHAPDF5_AVAILABLE) then pdf_data%type = STRF_LHAPDF5 end if write (msg_buffer, "(A,I0)") caller & // ": interfacing LHAPDF set #", pdf_data%set call msg_message () else if (beam_structure%contains ("pdf_builtin")) then pdf_data%type = STRF_PDF_BUILTIN write (msg_buffer, "(A,I0)") caller & // ": interfacing PDF builtin set #", pdf_data%set call msg_message () end if select case (pdf_data%type) case (STRF_LHAPDF6) pdf_data%xmin = pdf_data%pdf%getxmin () pdf_data%xmax = pdf_data%pdf%getxmax () pdf_data%qmin = sqrt(pdf_data%pdf%getq2min ()) pdf_data%qmax = sqrt(pdf_data%pdf%getq2max ()) case (STRF_LHAPDF5) call GetXminM (1, lhapdf_member, xmin) call GetXmaxM (1, lhapdf_member, xmax) call GetQ2minM (1, lhapdf_member, q2min) call GetQ2maxM (1, lhapdf_member, q2max) pdf_data%xmin = xmin pdf_data%xmax = xmax pdf_data%qmin = sqrt(q2min) pdf_data%qmax = sqrt(q2max) end select end subroutine pdf_data_setup @ %def pdf_data_setup @ This could be overloaded with a version that only asks for a specific flavor as it is supported by LHAPDF6. <>= procedure :: evolve => pdf_data_evolve <>= module subroutine pdf_data_evolve (pdf_data, x, q_in, f) class(pdf_data_t), intent(inout) :: pdf_data real(double), intent(in) :: x, q_in real(double), dimension(-6:6), intent(out) :: f end subroutine pdf_data_evolve <>= module subroutine pdf_data_evolve (pdf_data, x, q_in, f) class(pdf_data_t), intent(inout) :: pdf_data real(double), intent(in) :: x, q_in real(double), dimension(-6:6), intent(out) :: f real(double) :: q select case (pdf_data%type) case (STRF_PDF_BUILTIN) call pdf_evolve_LHAPDF (pdf_data%set, x, q_in, f) case (STRF_LHAPDF6) q = min (pdf_data%qmax, q_in) q = max (pdf_data%qmin, q) call pdf_data%pdf%evolve_pdfm (x, q, f) case (STRF_LHAPDF5) q = min (pdf_data%qmax, q_in) q = max (pdf_data%qmin, q) call evolvePDFM (pdf_data%set, x, q, f) case default call msg_fatal ("PDF function: unknown PDF method.") end select end subroutine pdf_data_evolve @ %def pdf_data_evolve @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Dispatch} @ <<[[dispatch_beams.f90]]>>= <> module dispatch_beams <> <> use constants, only: PI, one use numeric_utils, only: vanishes use diagnostics use os_interface, only: os_data_t use variables, only: var_list_t use rng_base, only: rng_factory_t use pdg_arrays use model_data, only: model_data_t use flavors, only: flavor_t use physics_defs, only: PHOTON use physics_defs, only: MZ_REF, ME_REF, ALPHA_QCD_MZ_REF, ALPHA_QED_ME_REF use sm_qcd, only: qcd_t, alpha_qcd_fixed_t, alpha_qcd_from_scale_t use sm_qcd, only: alpha_qcd_from_lambda_t use sm_qed, only: qed_t, alpha_qed_fixed_t, alpha_qed_from_scale_t use beam_structures use dispatch_rng, only: dispatch_rng_factory use dispatch_rng, only: update_rng_seed_in_var_list use sf_base use sf_mappings use sf_isr use sf_epa use sf_ewa use sf_escan use sf_gaussian use sf_beam_events use sf_circe1 use sf_circe2 use sf_pdf_builtin use sf_lhapdf <> <> <> <> interface <> end interface contains <> end module dispatch_beams @ %def dispatch_beams @ <<[[dispatch_beams_sub.f90]]>>= <> submodule (dispatch_beams) dispatch_beams_s implicit none contains <> end submodule dispatch_beams_s @ %def dispatch_beams_s @ This data type is a container for transferring structure-function specific data from the [[dispatch_sf_data]] to the [[dispatch_sf_channels]] subroutine. <>= public :: sf_prop_t <>= type :: sf_prop_t real(default), dimension(2) :: isr_eps = 1 end type sf_prop_t @ %def sf_prop_t @ Allocate a structure-function configuration object according to the [[sf_method]] string. The [[sf_prop]] object can be used to transfer structure-function specific data up and to the [[dispatch_sf_channels]] subroutine below, so they can be used for particular mappings. The [[var_list_global]] object is used for the RNG generator seed. It is intent(inout) because the RNG generator seed may change during initialization. The [[pdg_in]] array is the array of incoming flavors, corresponding to the upstream structure function or the beam array. This will be checked for the structure function in question and replaced by the outgoing flavors. The [[pdg_prc]] array is the array of incoming flavors (beam index, component index) for the hard process. Due to a bug in gfortran 7/8/9 this has to remain in the main module. <>= public :: dispatch_sf_data <>= subroutine dispatch_sf_data (data, sf_method, i_beam, sf_prop, & var_list, var_list_global, model, & os_data, sqrts, pdg_in, pdg_prc, polarized) class(sf_data_t), allocatable, intent(inout) :: data type(string_t), intent(in) :: sf_method integer, dimension(:), intent(in) :: i_beam type(pdg_array_t), dimension(:), intent(inout) :: pdg_in type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc type(sf_prop_t), intent(inout) :: sf_prop type(var_list_t), intent(in) :: var_list type(var_list_t), intent(inout) :: var_list_global integer :: next_rng_seed class(model_data_t), target, intent(in) :: model type(os_data_t), intent(in) :: os_data real(default), intent(in) :: sqrts logical, intent(in) :: polarized type(pdg_array_t), dimension(:), allocatable :: pdg_out real(default) :: isr_alpha, isr_q_max, isr_mass integer :: isr_order logical :: isr_recoil, isr_keep_energy real(default) :: epa_alpha, epa_x_min, epa_q_min, epa_q_max, epa_mass logical :: epa_recoil, epa_keep_energy integer :: epa_int_mode type(string_t) :: epa_mode real(default) :: ewa_x_min, ewa_pt_max, ewa_mass logical :: ewa_recoil, ewa_keep_energy type(pdg_array_t), dimension(:), allocatable :: pdg_prc1 integer :: ewa_id type(string_t) :: pdf_name type(string_t) :: lhapdf_dir, lhapdf_file type(string_t), dimension(13) :: lhapdf_photon_sets integer :: lhapdf_member, lhapdf_photon_scheme logical :: hoppet_b_matching class(rng_factory_t), allocatable :: rng_factory logical :: circe1_photon1, circe1_photon2, circe1_generate, & circe1_with_radiation real(default) :: circe1_sqrts, circe1_eps integer :: circe1_version, circe1_chattiness, & circe1_revision character(6) :: circe1_accelerator logical :: circe2_polarized type(string_t) :: circe2_design, circe2_file real(default), dimension(2) :: gaussian_spread logical :: beam_events_warn_eof type(string_t) :: beam_events_dir, beam_events_file logical :: escan_normalize integer :: i lhapdf_photon_sets = [var_str ("DOG0.LHgrid"), var_str ("DOG1.LHgrid"), & var_str ("DGG.LHgrid"), var_str ("LACG.LHgrid"), & var_str ("GSG0.LHgrid"), var_str ("GSG1.LHgrid"), & var_str ("GSG960.LHgrid"), var_str ("GSG961.LHgrid"), & var_str ("GRVG0.LHgrid"), var_str ("GRVG1.LHgrid"), & var_str ("ACFGPG.LHgrid"), var_str ("WHITG.LHgrid"), & var_str ("SASG.LHgrid")] select case (char (sf_method)) case ("pdf_builtin") allocate (pdf_builtin_data_t :: data) select type (data) type is (pdf_builtin_data_t) pdf_name = & var_list%get_sval (var_str ("$pdf_builtin_set")) hoppet_b_matching = & var_list%get_lval (var_str ("?hoppet_b_matching")) call data%init ( & model, pdg_in(i_beam(1)), & name = pdf_name, & path = os_data%pdf_builtin_datapath, & hoppet_b_matching = hoppet_b_matching) end select case ("pdf_builtin_photon") call msg_fatal ("Currently, there are no photon PDFs built into WHIZARD,", & [var_str ("for the photon content inside a proton or neutron use"), & var_str ("the 'lhapdf_photon' structure function.")]) case ("lhapdf") allocate (lhapdf_data_t :: data) if (pdg_in(i_beam(1))%get (1) == PHOTON) then call msg_fatal ("The 'lhapdf' structure is intended only for protons and", & [var_str ("pions, please use 'lhapdf_photon' for photon beams.")]) end if lhapdf_dir = & var_list%get_sval (var_str ("$lhapdf_dir")) lhapdf_file = & var_list%get_sval (var_str ("$lhapdf_file")) lhapdf_member = & var_list%get_ival (var_str ("lhapdf_member")) lhapdf_photon_scheme = & var_list%get_ival (var_str ("lhapdf_photon_scheme")) hoppet_b_matching = & var_list%get_lval (var_str ("?hoppet_b_matching")) select type (data) type is (lhapdf_data_t) call data%init & (model, pdg_in(i_beam(1)), & lhapdf_dir, lhapdf_file, lhapdf_member, & lhapdf_photon_scheme, hoppet_b_matching) end select case ("lhapdf_photon") allocate (lhapdf_data_t :: data) if (pdg_in(i_beam(1))%get_length () /= 1 .or. & pdg_in(i_beam(1))%get (1) /= PHOTON) then call msg_fatal ("The 'lhapdf_photon' structure function is exclusively for", & [var_str ("photon PDFs, i.e. for photons as beam particles")]) end if lhapdf_dir = & var_list%get_sval (var_str ("$lhapdf_dir")) lhapdf_file = & var_list%get_sval (var_str ("$lhapdf_photon_file")) lhapdf_member = & var_list%get_ival (var_str ("lhapdf_member")) lhapdf_photon_scheme = & var_list%get_ival (var_str ("lhapdf_photon_scheme")) if (.not. any (lhapdf_photon_sets == lhapdf_file)) then call msg_fatal ("This PDF set is not supported or not " // & "intended for photon beams.") end if select type (data) type is (lhapdf_data_t) call data%init & (model, pdg_in(i_beam(1)), & lhapdf_dir, lhapdf_file, lhapdf_member, & lhapdf_photon_scheme) end select case ("isr") allocate (isr_data_t :: data) isr_alpha = & var_list%get_rval (var_str ("isr_alpha")) if (vanishes (isr_alpha)) then isr_alpha = (var_list%get_rval (var_str ("ee"))) & ** 2 / (4 * PI) end if isr_q_max = & var_list%get_rval (var_str ("isr_q_max")) if (vanishes (isr_q_max)) then isr_q_max = sqrts end if isr_mass = var_list%get_rval (var_str ("isr_mass")) isr_order = var_list%get_ival (var_str ("isr_order")) isr_recoil = var_list%get_lval (var_str ("?isr_recoil")) isr_keep_energy = var_list%get_lval (var_str ("?isr_keep_energy")) select type (data) type is (isr_data_t) call data%init & (model, pdg_in (i_beam(1)), isr_alpha, isr_q_max, & isr_mass, isr_order, recoil = isr_recoil, keep_energy = & isr_keep_energy) call data%check () sf_prop%isr_eps(i_beam(1)) = data%get_eps () end select case ("epa") allocate (epa_data_t :: data) epa_mode = var_list%get_sval (var_str ("$epa_mode")) epa_int_mode = 0 epa_alpha = var_list%get_rval (var_str ("epa_alpha")) if (vanishes (epa_alpha)) then epa_alpha = (var_list%get_rval (var_str ("ee"))) & ** 2 / (4 * PI) end if epa_x_min = var_list%get_rval (var_str ("epa_x_min")) epa_q_min = var_list%get_rval (var_str ("epa_q_min")) epa_q_max = var_list%get_rval (var_str ("epa_q_max")) if (vanishes (epa_q_max)) then epa_q_max = sqrts end if select case (char (epa_mode)) case ("default", "Budnev_617") epa_int_mode = 0 case ("Budnev_616e") epa_int_mode = 1 case ("log_power") epa_int_mode = 2 epa_q_max = sqrts case ("log_simple") epa_int_mode = 3 epa_q_max = sqrts case ("log") epa_int_mode = 4 epa_q_max = sqrts case default call msg_fatal ("EPA: unsupported EPA mode; please choose " // & "'default', 'Budnev_616', 'Budnev_616e', 'log_power', " // & "'log_simple', or 'log'") end select epa_mass = var_list%get_rval (var_str ("epa_mass")) epa_recoil = var_list%get_lval (var_str ("?epa_recoil")) epa_keep_energy = var_list%get_lval (var_str ("?epa_keep_energy")) select type (data) type is (epa_data_t) call data%init & (model, epa_int_mode, pdg_in (i_beam(1)), epa_alpha, & epa_x_min, epa_q_min, epa_q_max, epa_mass, & recoil = epa_recoil, keep_energy = epa_keep_energy) call data%check () end select case ("ewa") allocate (ewa_data_t :: data) allocate (pdg_prc1 (size (pdg_prc, 2))) pdg_prc1 = pdg_prc(i_beam(1),:) if (any (pdg_prc1%get_length () /= 1) & .or. any (pdg_prc1 /= pdg_prc1(1))) then call msg_fatal & ("EWA: process incoming particle (W/Z) must be unique") end if ewa_id = abs (pdg_prc1(1)%get (1)) ewa_x_min = var_list%get_rval (var_str ("ewa_x_min")) ewa_pt_max = var_list%get_rval (var_str ("ewa_pt_max")) if (vanishes (ewa_pt_max)) then ewa_pt_max = sqrts end if ewa_mass = var_list%get_rval (var_str ("ewa_mass")) ewa_recoil = var_list%get_lval (& var_str ("?ewa_recoil")) ewa_keep_energy = var_list%get_lval (& var_str ("?ewa_keep_energy")) select type (data) type is (ewa_data_t) call data%init & (model, pdg_in (i_beam(1)), ewa_x_min, & ewa_pt_max, sqrts, ewa_recoil, & ewa_keep_energy, ewa_mass) call data%set_id (ewa_id) call data%check () end select case ("circe1") allocate (circe1_data_t :: data) select type (data) type is (circe1_data_t) circe1_photon1 = & var_list%get_lval (var_str ("?circe1_photon1")) circe1_photon2 = & var_list%get_lval (var_str ("?circe1_photon2")) circe1_sqrts = & var_list%get_rval (var_str ("circe1_sqrts")) circe1_eps = & var_list%get_rval (var_str ("circe1_eps")) if (circe1_sqrts <= 0) circe1_sqrts = sqrts circe1_generate = & var_list%get_lval (var_str ("?circe1_generate")) circe1_version = & var_list%get_ival (var_str ("circe1_ver")) circe1_revision = & var_list%get_ival (var_str ("circe1_rev")) circe1_accelerator = & char (var_list%get_sval (var_str ("$circe1_acc"))) circe1_chattiness = & var_list%get_ival (var_str ("circe1_chat")) circe1_with_radiation = & var_list%get_lval (var_str ("?circe1_with_radiation")) call data%init (model, pdg_in, circe1_sqrts, circe1_eps, & [circe1_photon1, circe1_photon2], & circe1_version, circe1_revision, circe1_accelerator, & circe1_chattiness, circe1_with_radiation) if (circe1_generate) then call msg_message ("CIRCE1: activating generator mode") call dispatch_rng_factory & (rng_factory, var_list_global, next_rng_seed) call update_rng_seed_in_var_list (var_list_global, next_rng_seed) call data%set_generator_mode (rng_factory) end if end select case ("circe2") allocate (circe2_data_t :: data) select type (data) type is (circe2_data_t) circe2_polarized = & var_list%get_lval (var_str ("?circe2_polarized")) circe2_file = & var_list%get_sval (var_str ("$circe2_file")) circe2_design = & var_list%get_sval (var_str ("$circe2_design")) call data%init (os_data, model, pdg_in, sqrts, & circe2_polarized, polarized, circe2_file, circe2_design) call msg_message ("CIRCE2: activating generator mode") call dispatch_rng_factory & (rng_factory, var_list_global, next_rng_seed) call update_rng_seed_in_var_list (var_list_global, next_rng_seed) call data%set_generator_mode (rng_factory) end select case ("gaussian") allocate (gaussian_data_t :: data) select type (data) type is (gaussian_data_t) gaussian_spread = & [var_list%get_rval (var_str ("gaussian_spread1")), & var_list%get_rval (var_str ("gaussian_spread2"))] call dispatch_rng_factory & (rng_factory, var_list_global, next_rng_seed) call update_rng_seed_in_var_list (var_list_global, next_rng_seed) call data%init (model, pdg_in, gaussian_spread, rng_factory) end select case ("beam_events") allocate (beam_events_data_t :: data) select type (data) type is (beam_events_data_t) beam_events_dir = os_data%whizard_beamsimpath beam_events_file = var_list%get_sval (& var_str ("$beam_events_file")) beam_events_warn_eof = var_list%get_lval (& var_str ("?beam_events_warn_eof")) call data%init (model, pdg_in, & beam_events_dir, beam_events_file, beam_events_warn_eof) end select case ("energy_scan") escan_normalize = & var_list%get_lval (var_str ("?energy_scan_normalize")) allocate (escan_data_t :: data) select type (data) type is (escan_data_t) if (escan_normalize) then call data%init (model, pdg_in) else call data%init (model, pdg_in, sqrts) end if end select case default if (associated (dispatch_sf_data_extra)) then call dispatch_sf_data_extra (data, sf_method, i_beam, & sf_prop, var_list, var_list_global, model, os_data, sqrts, pdg_in, & pdg_prc, polarized) end if if (.not. allocated (data)) then call msg_fatal ("Structure function '" & // char (sf_method) // "' not implemented") end if end select if (allocated (data)) then allocate (pdg_out (size (pdg_prc, 1))) call data%get_pdg_out (pdg_out) do i = 1, size (i_beam) pdg_in(i_beam(i)) = pdg_out(i) end do end if end subroutine dispatch_sf_data @ %def dispatch_sf_data @ This is a hook that allows us to inject further handlers for structure-function objects, in particular a test structure function. <>= public :: dispatch_sf_data_extra <>= procedure (dispatch_sf_data), pointer :: & dispatch_sf_data_extra => null () @ %def dispatch_sf_data_extra @ This is an auxiliary procedure, used by the beam-structure expansion: tell for a given structure function name, whether it corresponds to a pair spectrum ($n=2$), a single-particle structure function ($n=1$), or nothing ($n=0$). Though [[energy_scan]] can in principle also be a pair spectrum, it always has only one parameter. <>= public :: strfun_mode <>= module function strfun_mode (name) result (n) type(string_t), intent(in) :: name integer :: n end function strfun_mode <>= module function strfun_mode (name) result (n) type(string_t), intent(in) :: name integer :: n select case (char (name)) case ("none") n = 0 case ("sf_test_0", "sf_test_1") n = 1 case ("pdf_builtin","pdf_builtin_photon", & "lhapdf","lhapdf_photon") n = 1 case ("isr","epa","ewa") n = 1 case ("circe1", "circe2") n = 2 case ("gaussian") n = 2 case ("beam_events") n = 2 case ("energy_scan") n = 2 case default n = -1 call msg_bug ("Structure function '" // char (name) & // "' not supported yet") end select end function strfun_mode @ %def strfun_mode @ Dispatch a whole structure-function chain, given beam data and beam structure data. This could be done generically, but we should look at the specific combination of structure functions in order to select appropriate mappings. The [[beam_structure]] argument gets copied because we want to expand it to canonical form (one valid structure-function entry per record) before proceeding further. The [[pdg_prc]] argument is the array of incoming flavors. The first index is the beam index, the second one the process component index. Each element is itself a PDG array, notrivial if there is a flavor sum for the incoming state of this component. The dispatcher is divided in two parts. The first part configures the structure function data themselves. After this, we can configure the phase space for the elementary process. <>= public :: dispatch_sf_config <>= module subroutine dispatch_sf_config (sf_config, sf_prop, beam_structure, & var_list, var_list_global, model, os_data, sqrts, pdg_prc) type(sf_config_t), dimension(:), allocatable, intent(out) :: sf_config type(sf_prop_t), intent(out) :: sf_prop type(beam_structure_t), intent(inout) :: beam_structure type(var_list_t), intent(in) :: var_list type(var_list_t), intent(inout) :: var_list_global class(model_data_t), target, intent(in) :: model type(os_data_t), intent(in) :: os_data real(default), intent(in) :: sqrts class(sf_data_t), allocatable :: sf_data type(beam_structure_t) :: beam_structure_tmp type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc type(string_t), dimension(:), allocatable :: prt_in type(pdg_array_t), dimension(:), allocatable :: pdg_in end subroutine dispatch_sf_config <>= module subroutine dispatch_sf_config (sf_config, sf_prop, beam_structure, & var_list, var_list_global, model, os_data, sqrts, pdg_prc) type(sf_config_t), dimension(:), allocatable, intent(out) :: sf_config type(sf_prop_t), intent(out) :: sf_prop type(beam_structure_t), intent(inout) :: beam_structure type(var_list_t), intent(in) :: var_list type(var_list_t), intent(inout) :: var_list_global class(model_data_t), target, intent(in) :: model type(os_data_t), intent(in) :: os_data real(default), intent(in) :: sqrts class(sf_data_t), allocatable :: sf_data type(beam_structure_t) :: beam_structure_tmp type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc type(string_t), dimension(:), allocatable :: prt_in type(pdg_array_t), dimension(:), allocatable :: pdg_in type(flavor_t) :: flv_in integer :: n_beam, n_record, i beam_structure_tmp = beam_structure call beam_structure_tmp%expand (strfun_mode) n_record = beam_structure_tmp%get_n_record () allocate (sf_config (n_record)) n_beam = beam_structure_tmp%get_n_beam () if (n_beam > 0) then allocate (prt_in (n_beam), pdg_in (n_beam)) prt_in = beam_structure_tmp%get_prt () do i = 1, n_beam call flv_in%init (prt_in(i), model) pdg_in(i) = flv_in%get_pdg () end do else n_beam = size (pdg_prc, 1) allocate (pdg_in (n_beam)) pdg_in = pdg_prc(:,1) end if do i = 1, n_record call dispatch_sf_data (sf_data, & beam_structure_tmp%get_name (i), & beam_structure_tmp%get_i_entry (i), & sf_prop, var_list, var_list_global, model, os_data, sqrts, & pdg_in, pdg_prc, & beam_structure_tmp%polarized ()) call sf_config(i)%init (beam_structure_tmp%get_i_entry (i), sf_data) deallocate (sf_data) end do end subroutine dispatch_sf_config @ %def dispatch_sf_config @ \subsection{QCD and QED coupling} Allocate the [[alpha]] (running coupling) component of the [[qcd]] block with a concrete implementation, depending on the variable settings in the [[global]] record. If a fixed $\alpha_s$ is requested, we do not allocate the [[qcd%alpha]] object. In this case, the matrix element code will just take the model parameter as-is, which implies fixed $\alpha_s$. If the object is allocated, the $\alpha_s$ value is computed and updated for each matrix-element call. Also fetch the [[alphas_nf]] variable from the list and store it in the QCD record. This is not used in the $\alpha_s$ calculation, but the QCD record thus becomes a messenger for this user parameter. Gfortran 7/8/9 bug: has to be part of main module. <>= public :: dispatch_qcd <>= subroutine dispatch_qcd (qcd, var_list, os_data) type(qcd_t), intent(inout) :: qcd type(var_list_t), intent(in) :: var_list type(os_data_t), intent(in) :: os_data logical :: fixed, from_mz, from_pdf_builtin, from_lhapdf, from_lambda_qcd real(default) :: mz, alpha_val, lambda integer :: nf, order, lhapdf_member type(string_t) :: pdfset, lhapdf_dir, lhapdf_file call unpack_variables () if (allocated (qcd%alpha)) deallocate (qcd%alpha) if (from_lhapdf .and. from_pdf_builtin) then call msg_fatal (" Mixing alphas evolution", & [var_str (" from LHAPDF and builtin PDF is not permitted")]) end if select case (count ([from_mz, from_pdf_builtin, from_lhapdf, from_lambda_qcd])) case (0) if (fixed) then allocate (alpha_qcd_fixed_t :: qcd%alpha) else call msg_fatal ("QCD alpha: no calculation mode set") end if case (2:) call msg_fatal ("QCD alpha: calculation mode is ambiguous") case (1) if (fixed) then call msg_fatal ("QCD alpha: use '?alphas_is_fixed = false' for " // & "running alphas") else if (from_mz) then allocate (alpha_qcd_from_scale_t :: qcd%alpha) else if (from_pdf_builtin) then allocate (alpha_qcd_pdf_builtin_t :: qcd%alpha) else if (from_lhapdf) then allocate (alpha_qcd_lhapdf_t :: qcd%alpha) else if (from_lambda_qcd) then allocate (alpha_qcd_from_lambda_t :: qcd%alpha) end if call msg_message ("QCD alpha: using a running strong coupling") end select call init_alpha () qcd%n_f = var_list%get_ival (var_str ("alphas_nf")) contains <> end subroutine dispatch_qcd @ %def dispatch_qcd @ <>= subroutine unpack_variables () fixed = var_list%get_lval (var_str ("?alphas_is_fixed")) from_mz = var_list%get_lval (var_str ("?alphas_from_mz")) from_pdf_builtin = & var_list%get_lval (var_str ("?alphas_from_pdf_builtin")) from_lhapdf = & var_list%get_lval (var_str ("?alphas_from_lhapdf")) from_lambda_qcd = & var_list%get_lval (var_str ("?alphas_from_lambda_qcd")) pdfset = var_list%get_sval (var_str ("$pdf_builtin_set")) lambda = var_list%get_rval (var_str ("lambda_qcd")) nf = var_list%get_ival (var_str ("alphas_nf")) order = var_list%get_ival (var_str ("alphas_order")) lhapdf_dir = var_list%get_sval (var_str ("$lhapdf_dir")) lhapdf_file = var_list%get_sval (var_str ("$lhapdf_file")) lhapdf_member = var_list%get_ival (var_str ("lhapdf_member")) if (var_list%contains (var_str ("mZ"))) then mz = var_list%get_rval (var_str ("mZ")) else mz = MZ_REF end if if (var_list%contains (var_str ("alphas"))) then alpha_val = var_list%get_rval (var_str ("alphas")) else alpha_val = ALPHA_QCD_MZ_REF end if end subroutine unpack_variables @ <>= subroutine init_alpha () select type (alpha => qcd%alpha) type is (alpha_qcd_fixed_t) alpha%val = alpha_val type is (alpha_qcd_from_scale_t) alpha%mu_ref = mz alpha%ref = alpha_val alpha%order = order alpha%nf = nf type is (alpha_qcd_from_lambda_t) alpha%lambda = lambda alpha%order = order alpha%nf = nf type is (alpha_qcd_pdf_builtin_t) call alpha%init (pdfset, & os_data%pdf_builtin_datapath) type is (alpha_qcd_lhapdf_t) call alpha%init (lhapdf_file, lhapdf_member, lhapdf_dir) end select end subroutine init_alpha @ @ Same for QED. Gfortran 7/8/9: has to be part of main module. <>= public :: dispatch_qed <>= subroutine dispatch_qed (qed, var_list) type(qed_t), intent(inout) :: qed type(var_list_t), intent(in) :: var_list logical :: fixed, from_me, analytic real(default) :: me, alpha_val integer :: nf, nlep, order call unpack_variables () if (allocated (qed%alpha)) deallocate (qed%alpha) select case (count ([from_me])) case (0) if (fixed) then allocate (alpha_qed_fixed_t :: qed%alpha) else call msg_fatal ("QED alpha: no calculation mode set") end if case (2:) call msg_fatal ("QED alpha: calculation mode is ambiguous") case (1) if (fixed) then call msg_fatal ("QED alpha: use '?alphas_is_fixed = false' for " // & "running alpha") else if (from_me) then allocate (alpha_qed_from_scale_t :: qed%alpha) end if call msg_message ("QED alpha: using a running electromagnetic coupling") end select call init_alpha () if (var_list%get_ival (var_str ("alpha_nf")) == -1) then qed%n_f = var_list%get_ival (var_str ("alphas_nf")) else qed%n_f = var_list%get_ival (var_str ("alpha_nf")) end if qed%n_lep = var_list%get_ival (var_str ("alpha_nlep")) contains <> end subroutine dispatch_qed @ %def dispatch_qed @ <>= subroutine unpack_variables () fixed = var_list%get_lval (var_str ("?alpha_is_fixed")) from_me = var_list%get_lval (var_str ("?alpha_from_me")) if (var_list%get_ival (var_str ("alpha_nf")) == -1) then nf = var_list%get_ival (var_str ("alphas_nf")) else nf = var_list%get_ival (var_str ("alpha_nf")) end if analytic = var_list%get_lval (var_str ("?alpha_evolve_analytic")) nlep = var_list%get_ival (var_str ("alpha_nlep")) order = var_list%get_ival (var_str ("alpha_order")) if (var_list%contains (var_str ("me"))) then me = var_list%get_rval (var_str ("me")) else me = ME_REF end if if (var_list%contains (var_str ("alpha_em_i"))) then alpha_val = one / var_list%get_rval (var_str ("alpha_em_i")) else alpha_val = ALPHA_QED_ME_REF end if end subroutine unpack_variables @ <>= subroutine init_alpha () select type (alpha => qed%alpha) type is (alpha_qed_fixed_t) alpha%val = alpha_val type is (alpha_qed_from_scale_t) alpha%mu_ref = me alpha%ref = alpha_val alpha%order = order alpha%nf = nf alpha%nlep = nlep alpha%analytic = analytic end select end subroutine init_alpha @ Index: trunk/share/tests/Makefile.am =================================================================== --- trunk/share/tests/Makefile.am (revision 8815) +++ trunk/share/tests/Makefile.am (revision 8816) @@ -1,1613 +1,1621 @@ ## Makefile.am -- Makefile for WHIZARD tests ## ## Process this file with automake to produce Makefile.in ## ######################################################################## # # Copyright (C) 1999-2022 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## EXTRA_DIST = \ $(TESTSUITE_MACROS) $(TESTSUITES_M4) $(TESTSUITES_SIN) \ $(TESTSUITE_TOOLS) \ $(REF_OUTPUT_FILES) \ cascades2_1.fds \ cascades2_2.fds \ cascades2_lexer_1.fds \ ext_tests_nmssm/nmssm.slha \ functional_tests/structure_2_inc.sin functional_tests/testproc_3.phs \ functional_tests/susyhit.in \ functional_tests/ufo_5_test.slha TESTSUITE_MACROS = testsuite.m4 TESTSUITE_TOOLS = \ check-debug-output.py \ check-debug-output-hadro.py \ check-hepmc-weights.py \ compare-histograms.py \ compare-integrals.py \ compare-integrals-multi.py \ compare-methods.py REF_OUTPUT_FILES = \ extra_integration_results.dat \ $(REF_OUTPUT_FILES_BASE) $(REF_OUTPUT_FILES_DOUBLE) \ $(REF_OUTPUT_FILES_PREC) $(REF_OUTPUT_FILES_EXT) \ $(REF_OUTPUT_FILES_QUAD) REF_OUTPUT_FILES_BASE = \ unit_tests/ref-output/analysis_1.ref \ unit_tests/ref-output/api_1.ref \ unit_tests/ref-output/api_2.ref \ unit_tests/ref-output/api_3.ref \ unit_tests/ref-output/api_4.ref \ unit_tests/ref-output/api_5.ref \ unit_tests/ref-output/api_6.ref \ unit_tests/ref-output/api_7.ref \ unit_tests/ref-output/api_8.ref \ unit_tests/ref-output/api_c_1.ref \ unit_tests/ref-output/api_c_2.ref \ unit_tests/ref-output/api_c_3.ref \ unit_tests/ref-output/api_c_4.ref \ unit_tests/ref-output/api_c_5.ref \ unit_tests/ref-output/api_cc_1.ref \ unit_tests/ref-output/api_cc_2.ref \ unit_tests/ref-output/api_cc_3.ref \ unit_tests/ref-output/api_cc_4.ref \ unit_tests/ref-output/api_cc_5.ref \ unit_tests/ref-output/api_hepmc2_1.ref \ unit_tests/ref-output/api_hepmc2_cc_1.ref \ unit_tests/ref-output/api_hepmc3_1.ref \ unit_tests/ref-output/api_hepmc3_cc_1.ref \ unit_tests/ref-output/api_lcio_1.ref \ unit_tests/ref-output/api_lcio_cc_1.ref \ unit_tests/ref-output/array_list_1.ref \ unit_tests/ref-output/auto_components_1.ref \ unit_tests/ref-output/auto_components_2.ref \ unit_tests/ref-output/auto_components_3.ref \ unit_tests/ref-output/beam_1.ref \ unit_tests/ref-output/beam_2.ref \ unit_tests/ref-output/beam_3.ref \ unit_tests/ref-output/beam_structures_1.ref \ unit_tests/ref-output/beam_structures_2.ref \ unit_tests/ref-output/beam_structures_3.ref \ unit_tests/ref-output/beam_structures_4.ref \ unit_tests/ref-output/beam_structures_5.ref \ unit_tests/ref-output/beam_structures_6.ref \ unit_tests/ref-output/binary_tree_1.ref \ unit_tests/ref-output/blha_1.ref \ unit_tests/ref-output/blha_2.ref \ unit_tests/ref-output/blha_3.ref \ unit_tests/ref-output/bloch_vectors_1.ref \ unit_tests/ref-output/bloch_vectors_2.ref \ unit_tests/ref-output/bloch_vectors_3.ref \ unit_tests/ref-output/bloch_vectors_4.ref \ unit_tests/ref-output/bloch_vectors_5.ref \ unit_tests/ref-output/bloch_vectors_6.ref \ unit_tests/ref-output/bloch_vectors_7.ref \ unit_tests/ref-output/cascades2_1.ref \ unit_tests/ref-output/cascades2_2.ref \ unit_tests/ref-output/cascades2_lexer_1.ref \ unit_tests/ref-output/cascades_1.ref \ unit_tests/ref-output/cascades_2.ref \ unit_tests/ref-output/color_1.ref \ unit_tests/ref-output/color_2.ref \ unit_tests/ref-output/commands_1.ref \ unit_tests/ref-output/commands_2.ref \ unit_tests/ref-output/commands_3.ref \ unit_tests/ref-output/commands_4.ref \ unit_tests/ref-output/commands_5.ref \ unit_tests/ref-output/commands_6.ref \ unit_tests/ref-output/commands_7.ref \ unit_tests/ref-output/commands_8.ref \ unit_tests/ref-output/commands_9.ref \ unit_tests/ref-output/commands_10.ref \ unit_tests/ref-output/commands_11.ref \ unit_tests/ref-output/commands_12.ref \ unit_tests/ref-output/commands_13.ref \ unit_tests/ref-output/commands_14.ref \ unit_tests/ref-output/commands_15.ref \ unit_tests/ref-output/commands_16.ref \ unit_tests/ref-output/commands_17.ref \ unit_tests/ref-output/commands_18.ref \ unit_tests/ref-output/commands_19.ref \ unit_tests/ref-output/commands_20.ref \ unit_tests/ref-output/commands_21.ref \ unit_tests/ref-output/commands_22.ref \ unit_tests/ref-output/commands_23.ref \ unit_tests/ref-output/commands_24.ref \ unit_tests/ref-output/commands_25.ref \ unit_tests/ref-output/commands_26.ref \ unit_tests/ref-output/commands_27.ref \ unit_tests/ref-output/commands_28.ref \ unit_tests/ref-output/commands_29.ref \ unit_tests/ref-output/commands_30.ref \ unit_tests/ref-output/commands_31.ref \ unit_tests/ref-output/commands_32.ref \ unit_tests/ref-output/commands_33.ref \ unit_tests/ref-output/commands_34.ref \ unit_tests/ref-output/compilations_1.ref \ unit_tests/ref-output/compilations_2.ref \ unit_tests/ref-output/compilations_3.ref \ unit_tests/ref-output/compilations_static_1.ref \ unit_tests/ref-output/compilations_static_2.ref \ unit_tests/ref-output/cputime_1.ref \ unit_tests/ref-output/cputime_2.ref \ unit_tests/ref-output/decays_1.ref \ unit_tests/ref-output/decays_2.ref \ unit_tests/ref-output/decays_3.ref \ unit_tests/ref-output/decays_4.ref \ unit_tests/ref-output/decays_5.ref \ unit_tests/ref-output/decays_6.ref \ unit_tests/ref-output/dispatch_1.ref \ unit_tests/ref-output/dispatch_2.ref \ unit_tests/ref-output/dispatch_7.ref \ unit_tests/ref-output/dispatch_8.ref \ unit_tests/ref-output/dispatch_10.ref \ unit_tests/ref-output/dispatch_11.ref \ unit_tests/ref-output/dispatch_mci_1.ref \ unit_tests/ref-output/dispatch_phs_1.ref \ unit_tests/ref-output/dispatch_phs_2.ref \ unit_tests/ref-output/dispatch_rng_1.ref \ unit_tests/ref-output/dispatch_transforms_1.ref \ unit_tests/ref-output/dispatch_transforms_2.ref \ unit_tests/ref-output/eio_ascii_1.ref \ unit_tests/ref-output/eio_ascii_2.ref \ unit_tests/ref-output/eio_ascii_3.ref \ unit_tests/ref-output/eio_ascii_4.ref \ unit_tests/ref-output/eio_ascii_5.ref \ unit_tests/ref-output/eio_ascii_6.ref \ unit_tests/ref-output/eio_ascii_7.ref \ unit_tests/ref-output/eio_ascii_8.ref \ unit_tests/ref-output/eio_ascii_9.ref \ unit_tests/ref-output/eio_ascii_10.ref \ unit_tests/ref-output/eio_ascii_11.ref \ unit_tests/ref-output/eio_base_1.ref \ unit_tests/ref-output/eio_checkpoints_1.ref \ unit_tests/ref-output/eio_data_1.ref \ unit_tests/ref-output/eio_data_2.ref \ unit_tests/ref-output/eio_direct_1.ref \ unit_tests/ref-output/eio_dump_1.ref \ unit_tests/ref-output/eio_hepmc2_1.ref \ unit_tests/ref-output/eio_hepmc2_2.ref \ unit_tests/ref-output/eio_hepmc2_3.ref \ unit_tests/ref-output/eio_hepmc3_1.ref \ unit_tests/ref-output/eio_hepmc3_2.ref \ unit_tests/ref-output/eio_hepmc3_3.ref \ unit_tests/ref-output/eio_lcio_1.ref \ unit_tests/ref-output/eio_lcio_2.ref \ unit_tests/ref-output/eio_lhef_1.ref \ unit_tests/ref-output/eio_lhef_2.ref \ unit_tests/ref-output/eio_lhef_3.ref \ unit_tests/ref-output/eio_lhef_4.ref \ unit_tests/ref-output/eio_lhef_5.ref \ unit_tests/ref-output/eio_lhef_6.ref \ unit_tests/ref-output/eio_raw_1.ref \ unit_tests/ref-output/eio_raw_2.ref \ unit_tests/ref-output/eio_stdhep_1.ref \ unit_tests/ref-output/eio_stdhep_2.ref \ unit_tests/ref-output/eio_stdhep_3.ref \ unit_tests/ref-output/eio_stdhep_4.ref \ unit_tests/ref-output/eio_weights_1.ref \ unit_tests/ref-output/eio_weights_2.ref \ unit_tests/ref-output/eio_weights_3.ref \ + unit_tests/ref-output/electron_pdfs_1.ref \ + unit_tests/ref-output/electron_pdfs_2.ref \ + unit_tests/ref-output/electron_pdfs_3.ref \ + unit_tests/ref-output/electron_pdfs_4.ref \ + unit_tests/ref-output/electron_pdfs_5.ref \ + unit_tests/ref-output/electron_pdfs_6.ref \ unit_tests/ref-output/epa_handler_1.ref \ unit_tests/ref-output/epa_handler_2.ref \ unit_tests/ref-output/epa_handler_3.ref \ unit_tests/ref-output/evaluator_1.ref \ unit_tests/ref-output/evaluator_2.ref \ unit_tests/ref-output/evaluator_3.ref \ unit_tests/ref-output/evaluator_4.ref \ unit_tests/ref-output/event_streams_1.ref \ unit_tests/ref-output/event_streams_2.ref \ unit_tests/ref-output/event_streams_3.ref \ unit_tests/ref-output/event_streams_4.ref \ unit_tests/ref-output/event_transforms_1.ref \ unit_tests/ref-output/events_1.ref \ unit_tests/ref-output/events_2.ref \ unit_tests/ref-output/events_3.ref \ unit_tests/ref-output/events_4.ref \ unit_tests/ref-output/events_5.ref \ unit_tests/ref-output/events_6.ref \ unit_tests/ref-output/events_7.ref \ unit_tests/ref-output/expressions_1.ref \ unit_tests/ref-output/expressions_2.ref \ unit_tests/ref-output/expressions_3.ref \ unit_tests/ref-output/expressions_4.ref \ unit_tests/ref-output/fks_regions_1.ref \ unit_tests/ref-output/fks_regions_2.ref \ unit_tests/ref-output/fks_regions_3.ref \ unit_tests/ref-output/fks_regions_4.ref \ unit_tests/ref-output/fks_regions_5.ref \ unit_tests/ref-output/fks_regions_6.ref \ unit_tests/ref-output/fks_regions_7.ref \ unit_tests/ref-output/fks_regions_8.ref \ unit_tests/ref-output/format_1.ref \ unit_tests/ref-output/grids_1.ref \ unit_tests/ref-output/grids_2.ref \ unit_tests/ref-output/grids_3.ref \ unit_tests/ref-output/grids_4.ref \ unit_tests/ref-output/grids_5.ref \ unit_tests/ref-output/hep_events_1.ref \ unit_tests/ref-output/hepmc2_interface_1.ref \ unit_tests/ref-output/hepmc3_interface_1.ref \ unit_tests/ref-output/integration_results_1.ref \ unit_tests/ref-output/integration_results_2.ref \ unit_tests/ref-output/integration_results_3.ref \ unit_tests/ref-output/integration_results_4.ref \ unit_tests/ref-output/integration_results_5.ref \ unit_tests/ref-output/integrations_1.ref \ unit_tests/ref-output/integrations_2.ref \ unit_tests/ref-output/integrations_3.ref \ unit_tests/ref-output/integrations_4.ref \ unit_tests/ref-output/integrations_5.ref \ unit_tests/ref-output/integrations_6.ref \ unit_tests/ref-output/integrations_7.ref \ unit_tests/ref-output/integrations_8.ref \ unit_tests/ref-output/integrations_9.ref \ unit_tests/ref-output/integrations_history_1.ref \ unit_tests/ref-output/interaction_1.ref \ unit_tests/ref-output/isr_handler_1.ref \ unit_tests/ref-output/isr_handler_2.ref \ unit_tests/ref-output/isr_handler_3.ref \ unit_tests/ref-output/iterations_1.ref \ unit_tests/ref-output/iterations_2.ref \ unit_tests/ref-output/iterator_1.ref \ unit_tests/ref-output/jets_1.ref \ unit_tests/ref-output/lcio_interface_1.ref \ unit_tests/ref-output/lexer_1.ref \ unit_tests/ref-output/mci_base_1.ref \ unit_tests/ref-output/mci_base_2.ref \ unit_tests/ref-output/mci_base_3.ref \ unit_tests/ref-output/mci_base_4.ref \ unit_tests/ref-output/mci_base_5.ref \ unit_tests/ref-output/mci_base_6.ref \ unit_tests/ref-output/mci_base_7.ref \ unit_tests/ref-output/mci_base_8.ref \ unit_tests/ref-output/mci_midpoint_1.ref \ unit_tests/ref-output/mci_midpoint_2.ref \ unit_tests/ref-output/mci_midpoint_3.ref \ unit_tests/ref-output/mci_midpoint_4.ref \ unit_tests/ref-output/mci_midpoint_5.ref \ unit_tests/ref-output/mci_midpoint_6.ref \ unit_tests/ref-output/mci_midpoint_7.ref \ unit_tests/ref-output/mci_none_1.ref \ unit_tests/ref-output/mci_vamp2_1.ref \ unit_tests/ref-output/mci_vamp2_2.ref \ unit_tests/ref-output/mci_vamp2_3.ref \ unit_tests/ref-output/mci_vamp_1.ref \ unit_tests/ref-output/mci_vamp_2.ref \ unit_tests/ref-output/mci_vamp_3.ref \ unit_tests/ref-output/mci_vamp_4.ref \ unit_tests/ref-output/mci_vamp_5.ref \ unit_tests/ref-output/mci_vamp_6.ref \ unit_tests/ref-output/mci_vamp_7.ref \ unit_tests/ref-output/mci_vamp_8.ref \ unit_tests/ref-output/mci_vamp_9.ref \ unit_tests/ref-output/mci_vamp_10.ref \ unit_tests/ref-output/mci_vamp_11.ref \ unit_tests/ref-output/mci_vamp_12.ref \ unit_tests/ref-output/mci_vamp_13.ref \ unit_tests/ref-output/mci_vamp_14.ref \ unit_tests/ref-output/mci_vamp_15.ref \ unit_tests/ref-output/mci_vamp_16.ref \ unit_tests/ref-output/md5_1.ref \ unit_tests/ref-output/models_1.ref \ unit_tests/ref-output/models_2.ref \ unit_tests/ref-output/models_3.ref \ unit_tests/ref-output/models_4.ref \ unit_tests/ref-output/models_5.ref \ unit_tests/ref-output/models_6.ref \ unit_tests/ref-output/models_7.ref \ unit_tests/ref-output/models_8.ref \ unit_tests/ref-output/models_9.ref \ unit_tests/ref-output/models_10.ref \ + unit_tests/ref-output/numeric_utils_1.ref \ + unit_tests/ref-output/numeric_utils_2.ref \ unit_tests/ref-output/os_interface_1.ref \ unit_tests/ref-output/parse_1.ref \ unit_tests/ref-output/particle_specifiers_1.ref \ unit_tests/ref-output/particle_specifiers_2.ref \ unit_tests/ref-output/particles_1.ref \ unit_tests/ref-output/particles_2.ref \ unit_tests/ref-output/particles_3.ref \ unit_tests/ref-output/particles_4.ref \ unit_tests/ref-output/particles_5.ref \ unit_tests/ref-output/particles_6.ref \ unit_tests/ref-output/particles_7.ref \ unit_tests/ref-output/particles_8.ref \ unit_tests/ref-output/particles_9.ref \ unit_tests/ref-output/parton_states_1.ref \ unit_tests/ref-output/pdg_arrays_1.ref \ unit_tests/ref-output/pdg_arrays_2.ref \ unit_tests/ref-output/pdg_arrays_3.ref \ unit_tests/ref-output/pdg_arrays_4.ref \ unit_tests/ref-output/pdg_arrays_5.ref \ unit_tests/ref-output/phs_base_1.ref \ unit_tests/ref-output/phs_base_2.ref \ unit_tests/ref-output/phs_base_3.ref \ unit_tests/ref-output/phs_base_4.ref \ unit_tests/ref-output/phs_base_5.ref \ unit_tests/ref-output/phs_fks_generator_1.ref \ unit_tests/ref-output/phs_fks_generator_2.ref \ unit_tests/ref-output/phs_fks_generator_3.ref \ unit_tests/ref-output/phs_fks_generator_4.ref \ unit_tests/ref-output/phs_fks_generator_5.ref \ unit_tests/ref-output/phs_fks_generator_6.ref \ unit_tests/ref-output/phs_fks_generator_7.ref \ unit_tests/ref-output/phs_forest_1.ref \ unit_tests/ref-output/phs_forest_2.ref \ unit_tests/ref-output/phs_none_1.ref \ unit_tests/ref-output/phs_points_1.ref \ unit_tests/ref-output/phs_rambo_1.ref \ unit_tests/ref-output/phs_rambo_2.ref \ unit_tests/ref-output/phs_rambo_3.ref \ unit_tests/ref-output/phs_rambo_4.ref \ unit_tests/ref-output/phs_single_1.ref \ unit_tests/ref-output/phs_single_2.ref \ unit_tests/ref-output/phs_single_3.ref \ unit_tests/ref-output/phs_single_4.ref \ unit_tests/ref-output/phs_tree_1.ref \ unit_tests/ref-output/phs_tree_2.ref \ unit_tests/ref-output/phs_wood_1.ref \ unit_tests/ref-output/phs_wood_2.ref \ unit_tests/ref-output/phs_wood_3.ref \ unit_tests/ref-output/phs_wood_4.ref \ unit_tests/ref-output/phs_wood_5.ref \ unit_tests/ref-output/phs_wood_6.ref \ unit_tests/ref-output/phs_wood_vis_1.ref \ unit_tests/ref-output/polarization_1.ref \ unit_tests/ref-output/polarization_2.ref \ unit_tests/ref-output/prc_omega_1.ref \ unit_tests/ref-output/prc_omega_2.ref \ unit_tests/ref-output/prc_omega_3.ref \ unit_tests/ref-output/prc_omega_4.ref \ unit_tests/ref-output/prc_omega_5.ref \ unit_tests/ref-output/prc_omega_6.ref \ unit_tests/ref-output/prc_omega_diags_1.ref \ unit_tests/ref-output/prc_recola_1.ref \ unit_tests/ref-output/prc_recola_2.ref \ unit_tests/ref-output/prc_template_me_1.ref \ unit_tests/ref-output/prc_template_me_2.ref \ unit_tests/ref-output/prc_test_1.ref \ unit_tests/ref-output/prc_test_2.ref \ unit_tests/ref-output/prc_test_3.ref \ unit_tests/ref-output/prc_test_4.ref \ unit_tests/ref-output/prclib_interfaces_1.ref \ unit_tests/ref-output/prclib_interfaces_2.ref \ unit_tests/ref-output/prclib_interfaces_3.ref \ unit_tests/ref-output/prclib_interfaces_4.ref \ unit_tests/ref-output/prclib_interfaces_5.ref \ unit_tests/ref-output/prclib_interfaces_6.ref \ unit_tests/ref-output/prclib_interfaces_7.ref \ unit_tests/ref-output/prclib_stacks_1.ref \ unit_tests/ref-output/prclib_stacks_2.ref \ unit_tests/ref-output/process_configurations_1.ref \ unit_tests/ref-output/process_configurations_2.ref \ unit_tests/ref-output/process_libraries_1.ref \ unit_tests/ref-output/process_libraries_2.ref \ unit_tests/ref-output/process_libraries_3.ref \ unit_tests/ref-output/process_libraries_4.ref \ unit_tests/ref-output/process_libraries_5.ref \ unit_tests/ref-output/process_libraries_6.ref \ unit_tests/ref-output/process_libraries_7.ref \ unit_tests/ref-output/process_libraries_8.ref \ unit_tests/ref-output/process_stacks_1.ref \ unit_tests/ref-output/process_stacks_2.ref \ unit_tests/ref-output/process_stacks_3.ref \ unit_tests/ref-output/process_stacks_4.ref \ unit_tests/ref-output/processes_1.ref \ unit_tests/ref-output/processes_2.ref \ unit_tests/ref-output/processes_3.ref \ unit_tests/ref-output/processes_4.ref \ unit_tests/ref-output/processes_5.ref \ unit_tests/ref-output/processes_6.ref \ unit_tests/ref-output/processes_7.ref \ unit_tests/ref-output/processes_8.ref \ unit_tests/ref-output/processes_9.ref \ unit_tests/ref-output/processes_10.ref \ unit_tests/ref-output/processes_11.ref \ unit_tests/ref-output/processes_12.ref \ unit_tests/ref-output/processes_13.ref \ unit_tests/ref-output/processes_14.ref \ unit_tests/ref-output/processes_15.ref \ unit_tests/ref-output/processes_16.ref \ unit_tests/ref-output/processes_17.ref \ unit_tests/ref-output/processes_18.ref \ unit_tests/ref-output/processes_19.ref \ unit_tests/ref-output/radiation_generator_1.ref \ unit_tests/ref-output/radiation_generator_2.ref \ unit_tests/ref-output/radiation_generator_3.ref \ unit_tests/ref-output/radiation_generator_4.ref \ unit_tests/ref-output/real_subtraction_1.ref \ unit_tests/ref-output/recoil_kinematics_1.ref \ unit_tests/ref-output/recoil_kinematics_2.ref \ unit_tests/ref-output/recoil_kinematics_3.ref \ unit_tests/ref-output/recoil_kinematics_4.ref \ unit_tests/ref-output/recoil_kinematics_5.ref \ unit_tests/ref-output/recoil_kinematics_6.ref \ unit_tests/ref-output/resonance_insertion_1.ref \ unit_tests/ref-output/resonance_insertion_2.ref \ unit_tests/ref-output/resonance_insertion_3.ref \ unit_tests/ref-output/resonance_insertion_4.ref \ unit_tests/ref-output/resonance_insertion_5.ref \ unit_tests/ref-output/resonance_insertion_6.ref \ unit_tests/ref-output/resonances_1.ref \ unit_tests/ref-output/resonances_2.ref \ unit_tests/ref-output/resonances_3.ref \ unit_tests/ref-output/resonances_4.ref \ unit_tests/ref-output/resonances_5.ref \ unit_tests/ref-output/resonances_6.ref \ unit_tests/ref-output/resonances_7.ref \ unit_tests/ref-output/restricted_subprocesses_1.ref \ unit_tests/ref-output/restricted_subprocesses_2.ref \ unit_tests/ref-output/restricted_subprocesses_3.ref \ unit_tests/ref-output/restricted_subprocesses_4.ref \ unit_tests/ref-output/restricted_subprocesses_5.ref \ unit_tests/ref-output/restricted_subprocesses_6.ref \ unit_tests/ref-output/rng_base_1.ref \ unit_tests/ref-output/rng_base_2.ref \ unit_tests/ref-output/rng_stream_1.ref \ unit_tests/ref-output/rng_stream_2.ref \ unit_tests/ref-output/rng_stream_3.ref \ unit_tests/ref-output/rng_tao_1.ref \ unit_tests/ref-output/rng_tao_2.ref \ unit_tests/ref-output/rt_data_1.ref \ unit_tests/ref-output/rt_data_2.ref \ unit_tests/ref-output/rt_data_3.ref \ unit_tests/ref-output/rt_data_4.ref \ unit_tests/ref-output/rt_data_5.ref \ unit_tests/ref-output/rt_data_6.ref \ unit_tests/ref-output/rt_data_7.ref \ unit_tests/ref-output/rt_data_8.ref \ unit_tests/ref-output/rt_data_9.ref \ unit_tests/ref-output/rt_data_10.ref \ unit_tests/ref-output/rt_data_11.ref \ unit_tests/ref-output/selectors_1.ref \ unit_tests/ref-output/selectors_2.ref \ unit_tests/ref-output/sf_aux_1.ref \ unit_tests/ref-output/sf_aux_2.ref \ unit_tests/ref-output/sf_aux_3.ref \ unit_tests/ref-output/sf_aux_4.ref \ unit_tests/ref-output/sf_base_1.ref \ unit_tests/ref-output/sf_base_2.ref \ unit_tests/ref-output/sf_base_3.ref \ unit_tests/ref-output/sf_base_4.ref \ unit_tests/ref-output/sf_base_5.ref \ unit_tests/ref-output/sf_base_6.ref \ unit_tests/ref-output/sf_base_7.ref \ unit_tests/ref-output/sf_base_8.ref \ unit_tests/ref-output/sf_base_9.ref \ unit_tests/ref-output/sf_base_10.ref \ unit_tests/ref-output/sf_base_11.ref \ unit_tests/ref-output/sf_base_12.ref \ unit_tests/ref-output/sf_base_13.ref \ unit_tests/ref-output/sf_base_14.ref \ unit_tests/ref-output/sf_beam_events_1.ref \ unit_tests/ref-output/sf_beam_events_2.ref \ unit_tests/ref-output/sf_beam_events_3.ref \ unit_tests/ref-output/sf_circe1_1.ref \ unit_tests/ref-output/sf_circe1_2.ref \ unit_tests/ref-output/sf_circe1_3.ref \ unit_tests/ref-output/sf_circe2_1.ref \ unit_tests/ref-output/sf_circe2_2.ref \ unit_tests/ref-output/sf_circe2_3.ref \ unit_tests/ref-output/sf_epa_1.ref \ unit_tests/ref-output/sf_epa_2.ref \ unit_tests/ref-output/sf_epa_3.ref \ unit_tests/ref-output/sf_epa_4.ref \ unit_tests/ref-output/sf_epa_5.ref \ unit_tests/ref-output/sf_escan_1.ref \ unit_tests/ref-output/sf_escan_2.ref \ unit_tests/ref-output/sf_ewa_1.ref \ unit_tests/ref-output/sf_ewa_2.ref \ unit_tests/ref-output/sf_ewa_3.ref \ unit_tests/ref-output/sf_ewa_4.ref \ unit_tests/ref-output/sf_ewa_5.ref \ unit_tests/ref-output/sf_gaussian_1.ref \ unit_tests/ref-output/sf_gaussian_2.ref \ unit_tests/ref-output/sf_isr_1.ref \ unit_tests/ref-output/sf_isr_2.ref \ unit_tests/ref-output/sf_isr_3.ref \ unit_tests/ref-output/sf_isr_4.ref \ unit_tests/ref-output/sf_isr_5.ref \ unit_tests/ref-output/sf_lhapdf5_1.ref \ unit_tests/ref-output/sf_lhapdf5_2.ref \ unit_tests/ref-output/sf_lhapdf5_3.ref \ unit_tests/ref-output/sf_lhapdf6_1.ref \ unit_tests/ref-output/sf_lhapdf6_2.ref \ unit_tests/ref-output/sf_lhapdf6_3.ref \ unit_tests/ref-output/sf_mappings_1.ref \ unit_tests/ref-output/sf_mappings_2.ref \ unit_tests/ref-output/sf_mappings_3.ref \ unit_tests/ref-output/sf_mappings_4.ref \ unit_tests/ref-output/sf_mappings_5.ref \ unit_tests/ref-output/sf_mappings_6.ref \ unit_tests/ref-output/sf_mappings_7.ref \ unit_tests/ref-output/sf_mappings_8.ref \ unit_tests/ref-output/sf_mappings_9.ref \ unit_tests/ref-output/sf_mappings_10.ref \ unit_tests/ref-output/sf_mappings_11.ref \ unit_tests/ref-output/sf_mappings_12.ref \ unit_tests/ref-output/sf_mappings_13.ref \ unit_tests/ref-output/sf_mappings_14.ref \ unit_tests/ref-output/sf_mappings_15.ref \ unit_tests/ref-output/sf_mappings_16.ref \ unit_tests/ref-output/sf_pdf_builtin_1.ref \ unit_tests/ref-output/sf_pdf_builtin_2.ref \ unit_tests/ref-output/sf_pdf_builtin_3.ref \ unit_tests/ref-output/shower_1.ref \ unit_tests/ref-output/shower_2.ref \ unit_tests/ref-output/shower_base_1.ref \ unit_tests/ref-output/simulations_1.ref \ unit_tests/ref-output/simulations_2.ref \ unit_tests/ref-output/simulations_3.ref \ unit_tests/ref-output/simulations_4.ref \ unit_tests/ref-output/simulations_5.ref \ unit_tests/ref-output/simulations_6.ref \ unit_tests/ref-output/simulations_7.ref \ unit_tests/ref-output/simulations_8.ref \ unit_tests/ref-output/simulations_9.ref \ unit_tests/ref-output/simulations_10.ref \ unit_tests/ref-output/simulations_11.ref \ unit_tests/ref-output/simulations_12.ref \ unit_tests/ref-output/simulations_13.ref \ unit_tests/ref-output/simulations_14.ref \ unit_tests/ref-output/simulations_15.ref \ unit_tests/ref-output/slha_1.ref \ unit_tests/ref-output/slha_2.ref \ unit_tests/ref-output/sm_physics_1.ref \ unit_tests/ref-output/sm_physics_2.ref \ unit_tests/ref-output/sm_physics_3.ref \ unit_tests/ref-output/sm_qcd_1.ref \ unit_tests/ref-output/sm_qed_1.ref \ unit_tests/ref-output/solver_1.ref \ unit_tests/ref-output/sorting_1.ref \ unit_tests/ref-output/state_matrix_1.ref \ unit_tests/ref-output/state_matrix_2.ref \ unit_tests/ref-output/state_matrix_3.ref \ unit_tests/ref-output/state_matrix_4.ref \ unit_tests/ref-output/state_matrix_5.ref \ unit_tests/ref-output/state_matrix_6.ref \ unit_tests/ref-output/state_matrix_7.ref \ unit_tests/ref-output/su_algebra_1.ref \ unit_tests/ref-output/su_algebra_2.ref \ unit_tests/ref-output/su_algebra_3.ref \ unit_tests/ref-output/su_algebra_4.ref \ unit_tests/ref-output/subevt_expr_1.ref \ unit_tests/ref-output/subevt_expr_2.ref \ unit_tests/ref-output/ttv_formfactors_1.ref \ unit_tests/ref-output/ttv_formfactors_2.ref \ unit_tests/ref-output/vamp2_1.ref \ unit_tests/ref-output/vamp2_2.ref \ unit_tests/ref-output/vamp2_3.ref \ unit_tests/ref-output/vamp2_4.ref \ unit_tests/ref-output/vamp2_5.ref \ unit_tests/ref-output/vegas_1.ref \ unit_tests/ref-output/vegas_2.ref \ unit_tests/ref-output/vegas_3.ref \ unit_tests/ref-output/vegas_4.ref \ unit_tests/ref-output/vegas_5.ref \ unit_tests/ref-output/vegas_6.ref \ unit_tests/ref-output/vegas_7.ref \ unit_tests/ref-output/whizard_lha_1.ref \ unit_tests/ref-output/xml_1.ref \ unit_tests/ref-output/xml_2.ref \ unit_tests/ref-output/xml_3.ref \ unit_tests/ref-output/xml_4.ref \ functional_tests/ref-output/alphas.ref \ functional_tests/ref-output/analyze_1.ref \ functional_tests/ref-output/analyze_2.ref \ functional_tests/ref-output/analyze_3.ref \ functional_tests/ref-output/analyze_4.ref \ functional_tests/ref-output/analyze_5.ref \ functional_tests/ref-output/analyze_6.ref \ functional_tests/ref-output/beam_events_1.ref \ functional_tests/ref-output/beam_events_4.ref \ functional_tests/ref-output/beam_setup_1.ref \ functional_tests/ref-output/beam_setup_2.ref \ functional_tests/ref-output/beam_setup_3.ref \ functional_tests/ref-output/beam_setup_4.ref \ functional_tests/ref-output/bjet_cluster.ref \ functional_tests/ref-output/br_redef_1.ref \ functional_tests/ref-output/cascades2_phs_1.ref \ functional_tests/ref-output/cascades2_phs_2.ref \ functional_tests/ref-output/circe1_1.ref \ functional_tests/ref-output/circe1_2.ref \ functional_tests/ref-output/circe1_3.ref \ functional_tests/ref-output/circe1_6.ref \ functional_tests/ref-output/circe1_10.ref \ functional_tests/ref-output/circe1_errors_1.ref \ functional_tests/ref-output/circe2_1.ref \ functional_tests/ref-output/circe2_2.ref \ functional_tests/ref-output/circe2_3.ref \ functional_tests/ref-output/cmdline_1.ref \ functional_tests/ref-output/colors.ref \ functional_tests/ref-output/colors_hgg.ref \ functional_tests/ref-output/cuts.ref \ functional_tests/ref-output/decay_err_1.ref \ functional_tests/ref-output/decay_err_2.ref \ functional_tests/ref-output/decay_err_3.ref \ functional_tests/ref-output/energy_scan_1.ref \ functional_tests/ref-output/ep_3.ref \ functional_tests/ref-output/epa_1.ref \ functional_tests/ref-output/epa_2.ref \ functional_tests/ref-output/epa_3.ref \ functional_tests/ref-output/epa_4.ref \ functional_tests/ref-output/event_dump_1.ref \ functional_tests/ref-output/event_dump_2.ref \ functional_tests/ref-output/event_eff_1.ref \ functional_tests/ref-output/event_eff_2.ref \ functional_tests/ref-output/event_failed_1.ref \ functional_tests/ref-output/event_weights_1.ref \ functional_tests/ref-output/event_weights_2.ref \ functional_tests/ref-output/ewa_4.ref \ functional_tests/ref-output/extpar.ref \ functional_tests/ref-output/fatal.ref \ functional_tests/ref-output/fatal_beam_decay.ref \ functional_tests/ref-output/fks_res_2.ref \ functional_tests/ref-output/flvsum_1.ref \ functional_tests/ref-output/gaussian_1.ref \ functional_tests/ref-output/gaussian_2.ref \ functional_tests/ref-output/hadronize_1.ref \ functional_tests/ref-output/hepmc_1.ref \ functional_tests/ref-output/hepmc_2.ref \ functional_tests/ref-output/hepmc_3.ref \ functional_tests/ref-output/hepmc_4.ref \ functional_tests/ref-output/hepmc_5.ref \ functional_tests/ref-output/hepmc_6.ref \ functional_tests/ref-output/hepmc_7.ref \ functional_tests/ref-output/hepmc_9.ref \ functional_tests/ref-output/hepmc_10.ref \ functional_tests/ref-output/isr_1.ref \ functional_tests/ref-output/isr_epa_1.ref \ functional_tests/ref-output/jets_xsec.ref \ functional_tests/ref-output/job_id_1.ref \ functional_tests/ref-output/job_id_2.ref \ functional_tests/ref-output/job_id_3.ref \ functional_tests/ref-output/job_id_4.ref \ functional_tests/ref-output/lcio_1.ref \ functional_tests/ref-output/lcio_3.ref \ functional_tests/ref-output/lcio_4.ref \ functional_tests/ref-output/lcio_5.ref \ functional_tests/ref-output/lcio_6.ref \ functional_tests/ref-output/lcio_8.ref \ functional_tests/ref-output/lcio_9.ref \ functional_tests/ref-output/lcio_10.ref \ functional_tests/ref-output/lcio_11.ref \ functional_tests/ref-output/lhef_1.ref \ functional_tests/ref-output/lhef_2.ref \ functional_tests/ref-output/lhef_3.ref \ functional_tests/ref-output/lhef_4.ref \ functional_tests/ref-output/lhef_5.ref \ functional_tests/ref-output/lhef_6.ref \ functional_tests/ref-output/lhef_9.ref \ functional_tests/ref-output/lhef_10.ref \ functional_tests/ref-output/lhef_11.ref \ functional_tests/ref-output/libraries_1.ref \ functional_tests/ref-output/libraries_2.ref \ functional_tests/ref-output/libraries_4.ref \ functional_tests/ref-output/method_ovm_1.ref \ functional_tests/ref-output/mlm_matching_fsr.ref \ functional_tests/ref-output/mlm_pythia6_isr.ref \ functional_tests/ref-output/model_change_1.ref \ functional_tests/ref-output/model_change_2.ref \ functional_tests/ref-output/model_change_3.ref \ functional_tests/ref-output/model_scheme_1.ref \ functional_tests/ref-output/model_test.ref \ functional_tests/ref-output/mssmtest_1.ref \ functional_tests/ref-output/mssmtest_2.ref \ functional_tests/ref-output/mssmtest_3.ref \ functional_tests/ref-output/multi_comp_4.ref \ functional_tests/ref-output/nlo_1.ref \ functional_tests/ref-output/nlo_2.ref \ functional_tests/ref-output/nlo_6.ref \ functional_tests/ref-output/nlo_decay_1.ref \ functional_tests/ref-output/observables_1.ref \ functional_tests/ref-output/openloops_1.ref \ functional_tests/ref-output/openloops_2.ref \ functional_tests/ref-output/openloops_4.ref \ functional_tests/ref-output/openloops_5.ref \ functional_tests/ref-output/openloops_6.ref \ functional_tests/ref-output/openloops_7.ref \ functional_tests/ref-output/openloops_8.ref \ functional_tests/ref-output/openloops_9.ref \ functional_tests/ref-output/openloops_10.ref \ functional_tests/ref-output/openloops_11.ref \ functional_tests/ref-output/pack_1.ref \ functional_tests/ref-output/parton_shower_1.ref \ functional_tests/ref-output/photon_isolation_1.ref \ functional_tests/ref-output/photon_isolation_2.ref \ functional_tests/ref-output/polarized_1.ref \ functional_tests/ref-output/process_log.ref \ functional_tests/ref-output/pythia6_1.ref \ functional_tests/ref-output/pythia6_2.ref \ functional_tests/ref-output/qcdtest_4.ref \ functional_tests/ref-output/qcdtest_5.ref \ functional_tests/ref-output/qcdtest_6.ref \ functional_tests/ref-output/qedtest_1.ref \ functional_tests/ref-output/qedtest_2.ref \ functional_tests/ref-output/qedtest_5.ref \ functional_tests/ref-output/qedtest_6.ref \ functional_tests/ref-output/qedtest_7.ref \ functional_tests/ref-output/qedtest_8.ref \ functional_tests/ref-output/qedtest_9.ref \ functional_tests/ref-output/qedtest_10.ref \ functional_tests/ref-output/rambo_vamp_1.ref \ functional_tests/ref-output/rambo_vamp_2.ref \ functional_tests/ref-output/real_partition_1.ref \ functional_tests/ref-output/rebuild_2.ref \ functional_tests/ref-output/rebuild_3.ref \ functional_tests/ref-output/rebuild_4.ref \ functional_tests/ref-output/recola_1.ref \ functional_tests/ref-output/recola_2.ref \ functional_tests/ref-output/recola_3.ref \ functional_tests/ref-output/recola_4.ref \ functional_tests/ref-output/recola_5.ref \ functional_tests/ref-output/recola_6.ref \ functional_tests/ref-output/recola_7.ref \ functional_tests/ref-output/recola_8.ref \ functional_tests/ref-output/recola_9.ref \ functional_tests/ref-output/resonances_5.ref \ functional_tests/ref-output/resonances_6.ref \ functional_tests/ref-output/resonances_7.ref \ functional_tests/ref-output/resonances_8.ref \ functional_tests/ref-output/resonances_9.ref \ functional_tests/ref-output/resonances_12.ref \ functional_tests/ref-output/restrictions.ref \ functional_tests/ref-output/reweight_1.ref \ functional_tests/ref-output/reweight_2.ref \ functional_tests/ref-output/reweight_3.ref \ functional_tests/ref-output/reweight_4.ref \ functional_tests/ref-output/reweight_5.ref \ functional_tests/ref-output/reweight_6.ref \ functional_tests/ref-output/reweight_7.ref \ functional_tests/ref-output/reweight_8.ref \ functional_tests/ref-output/reweight_9.ref \ functional_tests/ref-output/reweight_10.ref \ functional_tests/ref-output/select_1.ref \ functional_tests/ref-output/select_2.ref \ functional_tests/ref-output/show_1.ref \ functional_tests/ref-output/show_2.ref \ functional_tests/ref-output/show_3.ref \ functional_tests/ref-output/show_4.ref \ functional_tests/ref-output/show_5.ref \ functional_tests/ref-output/shower_err_1.ref \ functional_tests/ref-output/sm_cms_1.ref \ functional_tests/ref-output/smtest_1.ref \ functional_tests/ref-output/smtest_3.ref \ functional_tests/ref-output/smtest_4.ref \ functional_tests/ref-output/smtest_5.ref \ functional_tests/ref-output/smtest_6.ref \ functional_tests/ref-output/smtest_7.ref \ functional_tests/ref-output/smtest_9.ref \ functional_tests/ref-output/smtest_10.ref \ functional_tests/ref-output/smtest_11.ref \ functional_tests/ref-output/smtest_12.ref \ functional_tests/ref-output/smtest_13.ref \ functional_tests/ref-output/smtest_14.ref \ functional_tests/ref-output/smtest_15.ref \ functional_tests/ref-output/smtest_16.ref \ functional_tests/ref-output/smtest_17.ref \ functional_tests/ref-output/spincor_1.ref \ functional_tests/ref-output/static_1.ref \ functional_tests/ref-output/static_2.ref \ functional_tests/ref-output/stdhep_1.ref \ functional_tests/ref-output/stdhep_2.ref \ functional_tests/ref-output/stdhep_3.ref \ functional_tests/ref-output/stdhep_4.ref \ functional_tests/ref-output/stdhep_5.ref \ functional_tests/ref-output/stdhep_6.ref \ functional_tests/ref-output/structure_1.ref \ functional_tests/ref-output/structure_2.ref \ functional_tests/ref-output/structure_3.ref \ functional_tests/ref-output/structure_4.ref \ functional_tests/ref-output/structure_5.ref \ functional_tests/ref-output/structure_6.ref \ functional_tests/ref-output/structure_7.ref \ functional_tests/ref-output/structure_8.ref \ functional_tests/ref-output/susyhit.ref \ functional_tests/ref-output/template_me_1.ref \ functional_tests/ref-output/template_me_2.ref \ functional_tests/ref-output/testproc_1.ref \ functional_tests/ref-output/testproc_2.ref \ functional_tests/ref-output/testproc_3.ref \ functional_tests/ref-output/testproc_4.ref \ functional_tests/ref-output/testproc_5.ref \ functional_tests/ref-output/testproc_6.ref \ functional_tests/ref-output/testproc_7.ref \ functional_tests/ref-output/testproc_8.ref \ functional_tests/ref-output/testproc_9.ref \ functional_tests/ref-output/testproc_10.ref \ functional_tests/ref-output/testproc_11.ref \ functional_tests/ref-output/ufo_1.ref \ functional_tests/ref-output/ufo_2.ref \ functional_tests/ref-output/ufo_3.ref \ functional_tests/ref-output/ufo_4.ref \ functional_tests/ref-output/ufo_5.ref \ functional_tests/ref-output/ufo_6.ref \ functional_tests/ref-output/user_prc_threshold_1.ref \ functional_tests/ref-output/user_prc_threshold_2.ref \ functional_tests/ref-output/vamp2_1.ref \ functional_tests/ref-output/vamp2_2.ref \ functional_tests/ref-output/vamp2_3.ref \ functional_tests/ref-output/vars.ref \ ext_tests_nlo/ref-output/nlo_ee4j.ref \ ext_tests_nlo/ref-output/nlo_ee4t.ref \ ext_tests_nlo/ref-output/nlo_ee5j.ref \ ext_tests_nlo/ref-output/nlo_eejj.ref \ ext_tests_nlo/ref-output/nlo_eejjj.ref \ ext_tests_nlo/ref-output/nlo_eett.ref \ ext_tests_nlo/ref-output/nlo_eetth.ref \ ext_tests_nlo/ref-output/nlo_eetthh.ref \ ext_tests_nlo/ref-output/nlo_eetthj.ref \ ext_tests_nlo/ref-output/nlo_eetthz.ref \ ext_tests_nlo/ref-output/nlo_eettwjj.ref \ ext_tests_nlo/ref-output/nlo_eettww.ref \ ext_tests_nlo/ref-output/nlo_eettz.ref \ ext_tests_nlo/ref-output/nlo_eettzj.ref \ ext_tests_nlo/ref-output/nlo_eettzjj.ref \ ext_tests_nlo/ref-output/nlo_eettzz.ref \ ext_tests_nlo/ref-output/nlo_ppzj_real_partition.ref \ ext_tests_nlo/ref-output/nlo_pptttt.ref \ ext_tests_nlo/ref-output/nlo_ppw.ref \ ext_tests_nlo/ref-output/nlo_ppz.ref \ ext_tests_nlo/ref-output/nlo_ppzj_sim_1.ref \ ext_tests_nlo/ref-output/nlo_ppzj_sim_2.ref \ ext_tests_nlo/ref-output/nlo_ppzj_sim_3.ref \ ext_tests_nlo/ref-output/nlo_ppzj_sim_4.ref \ ext_tests_nlo/ref-output/nlo_ppzw.ref \ ext_tests_nlo/ref-output/nlo_ppzz.ref \ ext_tests_nlo/ref-output/nlo_ppee_ew.ref \ ext_tests_nlo/ref-output/nlo_pphee_ew.ref \ ext_tests_nlo/ref-output/nlo_pphjj_ew.ref \ ext_tests_nlo/ref-output/nlo_pphz_ew.ref \ ext_tests_nlo/ref-output/nlo_ppllll_ew.ref \ ext_tests_nlo/ref-output/nlo_ppllnn_ew.ref \ ext_tests_nlo/ref-output/nlo_pptj_ew.ref \ ext_tests_nlo/ref-output/nlo_ppwhh_ew.ref \ ext_tests_nlo/ref-output/nlo_ppww_ew.ref \ ext_tests_nlo/ref-output/nlo_ppwzh_ew.ref \ ext_tests_nlo/ref-output/nlo_ppz_ew.ref \ ext_tests_nlo/ref-output/nlo_ppzzz_ew.ref # Reference files that depend on the numerical precision REF_OUTPUT_FILES_DOUBLE = \ functional_tests/ref-output-double/beam_events_2.ref \ functional_tests/ref-output-double/beam_events_3.ref \ functional_tests/ref-output-double/beam_setup_5.ref \ functional_tests/ref-output-double/circe1_4.ref \ functional_tests/ref-output-double/circe1_5.ref \ functional_tests/ref-output-double/circe1_7.ref \ functional_tests/ref-output-double/circe1_8.ref \ functional_tests/ref-output-double/circe1_9.ref \ functional_tests/ref-output-double/circe1_photons_1.ref \ functional_tests/ref-output-double/circe1_photons_2.ref \ functional_tests/ref-output-double/circe1_photons_3.ref \ functional_tests/ref-output-double/circe1_photons_4.ref \ functional_tests/ref-output-double/circe1_photons_5.ref \ functional_tests/ref-output-double/colors_2.ref \ functional_tests/ref-output-double/defaultcuts.ref \ functional_tests/ref-output-double/ep_1.ref \ functional_tests/ref-output-double/ep_2.ref \ functional_tests/ref-output-double/ewa_1.ref \ functional_tests/ref-output-double/ewa_2.ref \ functional_tests/ref-output-double/ewa_3.ref \ functional_tests/ref-output-double/fks_res_1.ref \ functional_tests/ref-output-double/fks_res_3.ref \ functional_tests/ref-output-double/helicity.ref \ functional_tests/ref-output-double/hepmc_8.ref \ functional_tests/ref-output-double/ilc.ref \ functional_tests/ref-output-double/isr_2.ref \ functional_tests/ref-output-double/isr_3.ref \ functional_tests/ref-output-double/isr_4.ref \ functional_tests/ref-output-double/isr_5.ref \ functional_tests/ref-output-double/isr_6.ref \ functional_tests/ref-output-double/lcio_2.ref \ functional_tests/ref-output-double/lcio_7.ref \ functional_tests/ref-output-double/lcio_12.ref \ functional_tests/ref-output-double/lhapdf5.ref \ functional_tests/ref-output-double/lhapdf6.ref \ functional_tests/ref-output-double/lhef_7.ref \ functional_tests/ref-output-double/mlm_matching_isr.ref \ functional_tests/ref-output-double/multi_comp_1.ref \ functional_tests/ref-output-double/multi_comp_2.ref \ functional_tests/ref-output-double/multi_comp_3.ref \ functional_tests/ref-output-double/testproc_12.ref \ functional_tests/ref-output-double/nlo_3.ref \ functional_tests/ref-output-double/nlo_4.ref \ functional_tests/ref-output-double/nlo_5.ref \ functional_tests/ref-output-double/nlo_7.ref \ functional_tests/ref-output-double/nlo_8.ref \ functional_tests/ref-output-double/nlo_9.ref \ functional_tests/ref-output-double/nlo_10.ref \ functional_tests/ref-output-double/observables_2.ref \ functional_tests/ref-output-double/openloops_3.ref \ functional_tests/ref-output-double/openloops_12.ref \ functional_tests/ref-output-double/openloops_13.ref \ functional_tests/ref-output-double/openloops_14.ref \ functional_tests/ref-output-double/parton_shower_2.ref \ functional_tests/ref-output-double/pdf_builtin.ref \ functional_tests/ref-output-double/powheg_1.ref \ functional_tests/ref-output-double/pythia6_3.ref \ functional_tests/ref-output-double/pythia6_4.ref \ functional_tests/ref-output-double/qcdtest_1.ref \ functional_tests/ref-output-double/qcdtest_2.ref \ functional_tests/ref-output-double/qcdtest_3.ref \ functional_tests/ref-output-double/qedtest_3.ref \ functional_tests/ref-output-double/qedtest_4.ref \ functional_tests/ref-output-double/resonances_1.ref \ functional_tests/ref-output-double/resonances_2.ref \ functional_tests/ref-output-double/resonances_3.ref \ functional_tests/ref-output-double/resonances_4.ref \ functional_tests/ref-output-double/resonances_10.ref \ functional_tests/ref-output-double/resonances_11.ref \ functional_tests/ref-output-double/resonances_13.ref \ functional_tests/ref-output-double/resonances_14.ref \ functional_tests/ref-output-double/resonances_15.ref \ functional_tests/ref-output-double/smtest_2.ref \ functional_tests/ref-output-double/smtest_8.ref \ functional_tests/ref-output-double/tauola_1.ref \ functional_tests/ref-output-double/tauola_2.ref \ functional_tests/ref-output-double/tauola_3.ref REF_OUTPUT_FILES_PREC = \ functional_tests/ref-output-prec/beam_setup_5.ref \ functional_tests/ref-output-prec/circe1_9.ref \ functional_tests/ref-output-prec/circe1_photons_1.ref \ functional_tests/ref-output-prec/circe1_photons_2.ref \ functional_tests/ref-output-prec/circe1_photons_3.ref \ functional_tests/ref-output-prec/circe1_photons_4.ref \ functional_tests/ref-output-prec/circe1_photons_5.ref \ functional_tests/ref-output-prec/colors_2.ref \ functional_tests/ref-output-prec/defaultcuts.ref \ functional_tests/ref-output-prec/ep_1.ref \ functional_tests/ref-output-prec/ep_2.ref \ functional_tests/ref-output-prec/ewa_1.ref \ functional_tests/ref-output-prec/fks_res_1.ref \ functional_tests/ref-output-prec/fks_res_3.ref \ functional_tests/ref-output-prec/helicity.ref \ functional_tests/ref-output-prec/ilc.ref \ functional_tests/ref-output-prec/lhapdf5.ref \ functional_tests/ref-output-prec/lhapdf6.ref \ functional_tests/ref-output-prec/lhef_7.ref \ functional_tests/ref-output-prec/multi_comp_1.ref \ functional_tests/ref-output-prec/multi_comp_2.ref \ functional_tests/ref-output-prec/multi_comp_3.ref \ functional_tests/ref-output-prec/testproc_12.ref \ functional_tests/ref-output-prec/nlo_3.ref \ functional_tests/ref-output-prec/nlo_4.ref \ functional_tests/ref-output-prec/parton_shower_2.ref \ functional_tests/ref-output-prec/pdf_builtin.ref \ functional_tests/ref-output-prec/qcdtest_1.ref \ functional_tests/ref-output-prec/qcdtest_2.ref \ functional_tests/ref-output-prec/qcdtest_3.ref \ functional_tests/ref-output-prec/qedtest_3.ref \ functional_tests/ref-output-prec/qedtest_4.ref \ functional_tests/ref-output-prec/smtest_2.ref \ functional_tests/ref-output-prec/smtest_8.ref REF_OUTPUT_FILES_EXT = \ functional_tests/ref-output-ext/beam_events_2.ref \ functional_tests/ref-output-ext/beam_events_3.ref \ functional_tests/ref-output-ext/circe1_4.ref \ functional_tests/ref-output-ext/circe1_5.ref \ functional_tests/ref-output-ext/circe1_7.ref \ functional_tests/ref-output-ext/circe1_8.ref \ functional_tests/ref-output-ext/ewa_2.ref \ functional_tests/ref-output-ext/ewa_3.ref \ functional_tests/ref-output-ext/hepmc_8.ref \ functional_tests/ref-output-ext/isr_2.ref \ functional_tests/ref-output-ext/isr_3.ref \ functional_tests/ref-output-ext/isr_4.ref \ functional_tests/ref-output-ext/isr_5.ref \ functional_tests/ref-output-ext/isr_6.ref \ functional_tests/ref-output-ext/lcio_2.ref \ functional_tests/ref-output-ext/lcio_7.ref \ functional_tests/ref-output-ext/lcio_12.ref \ functional_tests/ref-output-ext/mlm_matching_isr.ref \ functional_tests/ref-output-ext/nlo_5.ref \ functional_tests/ref-output-ext/nlo_7.ref \ functional_tests/ref-output-ext/nlo_8.ref \ functional_tests/ref-output-ext/nlo_9.ref \ functional_tests/ref-output-ext/nlo_10.ref \ functional_tests/ref-output-ext/observables_2.ref \ functional_tests/ref-output-ext/openloops_3.ref \ functional_tests/ref-output-ext/openloops_12.ref \ functional_tests/ref-output-ext/openloops_13.ref \ functional_tests/ref-output-ext/openloops_14.ref \ functional_tests/ref-output-ext/powheg_1.ref \ functional_tests/ref-output-ext/pythia6_3.ref \ functional_tests/ref-output-ext/pythia6_4.ref \ functional_tests/ref-output-ext/resonances_1.ref \ functional_tests/ref-output-ext/resonances_2.ref \ functional_tests/ref-output-ext/resonances_3.ref \ functional_tests/ref-output-ext/resonances_4.ref \ functional_tests/ref-output-ext/resonances_10.ref \ functional_tests/ref-output-ext/resonances_11.ref \ functional_tests/ref-output-ext/resonances_13.ref \ functional_tests/ref-output-ext/resonances_14.ref \ functional_tests/ref-output-ext/resonances_15.ref \ functional_tests/ref-output-ext/tauola_1.ref \ functional_tests/ref-output-ext/tauola_2.ref \ functional_tests/ref-output-ext/tauola_3.ref REF_OUTPUT_FILES_QUAD = \ functional_tests/ref-output-quad/beam_events_2.ref \ functional_tests/ref-output-quad/beam_events_3.ref \ functional_tests/ref-output-quad/circe1_4.ref \ functional_tests/ref-output-quad/circe1_5.ref \ functional_tests/ref-output-quad/circe1_7.ref \ functional_tests/ref-output-quad/circe1_8.ref \ functional_tests/ref-output-quad/ewa_2.ref \ functional_tests/ref-output-quad/ewa_3.ref \ functional_tests/ref-output-quad/hepmc_8.ref \ functional_tests/ref-output-quad/isr_2.ref \ functional_tests/ref-output-quad/isr_3.ref \ functional_tests/ref-output-quad/isr_4.ref \ functional_tests/ref-output-quad/isr_5.ref \ functional_tests/ref-output-quad/isr_6.ref \ functional_tests/ref-output-quad/lcio_2.ref \ functional_tests/ref-output-quad/lcio_7.ref \ functional_tests/ref-output-quad/lcio_12.ref \ functional_tests/ref-output-quad/mlm_matching_isr.ref \ functional_tests/ref-output-quad/nlo_5.ref \ functional_tests/ref-output-quad/nlo_7.ref \ functional_tests/ref-output-quad/nlo_8.ref \ functional_tests/ref-output-quad/nlo_9.ref \ functional_tests/ref-output-quad/nlo_10.ref \ functional_tests/ref-output-quad/observables_2.ref \ functional_tests/ref-output-quad/openloops_3.ref \ functional_tests/ref-output-quad/openloops_12.ref \ functional_tests/ref-output-quad/openloops_13.ref \ functional_tests/ref-output-quad/openloops_14.ref \ functional_tests/ref-output-quad/powheg_1.ref \ functional_tests/ref-output-quad/pythia6_3.ref \ functional_tests/ref-output-quad/pythia6_4.ref \ functional_tests/ref-output-quad/resonances_1.ref \ functional_tests/ref-output-quad/resonances_2.ref \ functional_tests/ref-output-quad/resonances_3.ref \ functional_tests/ref-output-quad/resonances_4.ref \ functional_tests/ref-output-quad/resonances_10.ref \ functional_tests/ref-output-quad/resonances_11.ref \ functional_tests/ref-output-quad/resonances_13.ref \ functional_tests/ref-output-quad/resonances_14.ref \ functional_tests/ref-output-quad/resonances_15.ref \ functional_tests/ref-output-quad/tauola_1.ref \ functional_tests/ref-output-quad/tauola_2.ref \ functional_tests/ref-output-quad/tauola_3.ref TESTSUITES_M4 = \ $(MISC_TESTS_M4) \ $(EXT_MSSM_M4) \ $(EXT_NMSSM_M4) TESTSUITES_SIN = \ $(MISC_TESTS_SIN) \ $(EXT_ILC_SIN) \ $(EXT_MSSM_SIN) \ $(EXT_NMSSM_SIN) \ $(EXT_SHOWER_SIN) \ $(EXT_NLO_SIN) \ $(EXT_NLO_ADD_SIN) MISC_TESTS_M4 = MISC_TESTS_SIN = \ functional_tests/alphas.sin \ functional_tests/analyze_1.sin \ functional_tests/analyze_2.sin \ functional_tests/analyze_3.sin \ functional_tests/analyze_4.sin \ functional_tests/analyze_5.sin \ functional_tests/analyze_6.sin \ functional_tests/beam_events_1.sin \ functional_tests/beam_events_2.sin \ functional_tests/beam_events_3.sin \ functional_tests/beam_events_4.sin \ functional_tests/beam_setup_1.sin \ functional_tests/beam_setup_2.sin \ functional_tests/beam_setup_3.sin \ functional_tests/beam_setup_4.sin \ functional_tests/beam_setup_5.sin \ functional_tests/bjet_cluster.sin \ functional_tests/br_redef_1.sin \ functional_tests/cascades2_phs_1.sin \ functional_tests/cascades2_phs_2.sin \ functional_tests/circe1_1.sin \ functional_tests/circe1_2.sin \ functional_tests/circe1_3.sin \ functional_tests/circe1_4.sin \ functional_tests/circe1_5.sin \ functional_tests/circe1_6.sin \ functional_tests/circe1_7.sin \ functional_tests/circe1_8.sin \ functional_tests/circe1_9.sin \ functional_tests/circe1_10.sin \ functional_tests/circe1_errors_1.sin \ functional_tests/circe1_photons_1.sin \ functional_tests/circe1_photons_2.sin \ functional_tests/circe1_photons_3.sin \ functional_tests/circe1_photons_4.sin \ functional_tests/circe1_photons_5.sin \ functional_tests/circe2_1.sin \ functional_tests/circe2_2.sin \ functional_tests/circe2_3.sin \ functional_tests/cmdline_1.sin \ functional_tests/cmdline_1_a.sin \ functional_tests/cmdline_1_b.sin \ functional_tests/colors.sin \ functional_tests/colors_2.sin \ functional_tests/colors_hgg.sin \ functional_tests/cuts.sin \ functional_tests/decay_err_1.sin \ functional_tests/decay_err_2.sin \ functional_tests/decay_err_3.sin \ functional_tests/defaultcuts.sin \ functional_tests/empty.sin \ functional_tests/energy_scan_1.sin \ functional_tests/ep_1.sin \ functional_tests/ep_2.sin \ functional_tests/ep_3.sin \ functional_tests/epa_1.sin \ functional_tests/epa_2.sin \ functional_tests/epa_3.sin \ functional_tests/epa_4.sin \ functional_tests/event_dump_1.sin \ functional_tests/event_dump_2.sin \ functional_tests/event_eff_1.sin \ functional_tests/event_eff_2.sin \ functional_tests/event_failed_1.sin \ functional_tests/event_weights_1.sin \ functional_tests/event_weights_2.sin \ functional_tests/ewa_1.sin \ functional_tests/ewa_2.sin \ functional_tests/ewa_3.sin \ functional_tests/ewa_4.sin \ functional_tests/extpar.sin \ functional_tests/fatal.sin \ functional_tests/fatal_beam_decay.sin \ functional_tests/fks_res_1.sin \ functional_tests/fks_res_2.sin \ functional_tests/fks_res_3.sin \ functional_tests/flvsum_1.sin \ functional_tests/gaussian_1.sin \ functional_tests/gaussian_2.sin \ functional_tests/hadronize_1.sin \ functional_tests/helicity.sin \ functional_tests/hepmc_1.sin \ functional_tests/hepmc_2.sin \ functional_tests/hepmc_3.sin \ functional_tests/hepmc_4.sin \ functional_tests/hepmc_5.sin \ functional_tests/hepmc_6.sin \ functional_tests/hepmc_7.sin \ functional_tests/hepmc_8.sin \ functional_tests/hepmc_9.sin \ functional_tests/hepmc_10.sin \ functional_tests/ilc.sin \ functional_tests/isr_1.sin \ functional_tests/isr_2.sin \ functional_tests/isr_3.sin \ functional_tests/isr_4.sin \ functional_tests/isr_5.sin \ functional_tests/isr_6.sin \ functional_tests/isr_epa_1.sin \ functional_tests/jets_xsec.sin \ functional_tests/job_id_1.sin \ functional_tests/job_id_2.sin \ functional_tests/job_id_3.sin \ functional_tests/job_id_4.sin \ functional_tests/lcio_1.sin \ functional_tests/lcio_2.sin \ functional_tests/lcio_3.sin \ functional_tests/lcio_4.sin \ functional_tests/lcio_5.sin \ functional_tests/lcio_6.sin \ functional_tests/lcio_7.sin \ functional_tests/lcio_8.sin \ functional_tests/lcio_9.sin \ functional_tests/lcio_10.sin \ functional_tests/lcio_11.sin \ functional_tests/lcio_12.sin \ functional_tests/lhapdf5.sin \ functional_tests/lhapdf6.sin \ functional_tests/lhef_1.sin \ functional_tests/lhef_2.sin \ functional_tests/lhef_3.sin \ functional_tests/lhef_4.sin \ functional_tests/lhef_5.sin \ functional_tests/lhef_6.sin \ functional_tests/lhef_7.sin \ functional_tests/lhef_8.sin \ functional_tests/lhef_9.sin \ functional_tests/lhef_10.sin \ functional_tests/lhef_11.sin \ functional_tests/libraries_1.sin \ functional_tests/libraries_2.sin \ functional_tests/libraries_3.sin \ functional_tests/libraries_4.sin \ functional_tests/method_ovm_1.sin \ functional_tests/mlm_matching_fsr.sin \ functional_tests/mlm_matching_isr.sin \ functional_tests/mlm_pythia6_isr.sin \ functional_tests/model_change_1.sin \ functional_tests/model_change_2.sin \ functional_tests/model_change_3.sin \ functional_tests/model_scheme_1.sin \ functional_tests/model_test.sin \ functional_tests/mssmtest_1.sin \ functional_tests/mssmtest_2.sin \ functional_tests/mssmtest_3.sin \ functional_tests/multi_comp_1.sin \ functional_tests/multi_comp_2.sin \ functional_tests/multi_comp_3.sin \ functional_tests/multi_comp_4.sin \ functional_tests/nlo_1.sin \ functional_tests/nlo_2.sin \ functional_tests/nlo_3.sin \ functional_tests/nlo_4.sin \ functional_tests/nlo_5.sin \ functional_tests/nlo_6.sin \ functional_tests/nlo_7.sin \ functional_tests/nlo_8.sin \ functional_tests/nlo_9.sin \ functional_tests/nlo_10.sin \ functional_tests/nlo_decay_1.sin \ functional_tests/observables_1.sin \ functional_tests/observables_2.sin \ functional_tests/openloops_1.sin \ functional_tests/openloops_2.sin \ functional_tests/openloops_3.sin \ functional_tests/openloops_4.sin \ functional_tests/openloops_5.sin \ functional_tests/openloops_6.sin \ functional_tests/openloops_7.sin \ functional_tests/openloops_8.sin \ functional_tests/openloops_9.sin \ functional_tests/openloops_10.sin \ functional_tests/openloops_11.sin \ functional_tests/openloops_12.sin \ functional_tests/openloops_13.sin \ functional_tests/openloops_14.sin \ functional_tests/pack_1.sin \ functional_tests/parton_shower_1.sin \ functional_tests/parton_shower_2.sin \ functional_tests/pdf_builtin.sin \ functional_tests/photon_isolation_1.sin \ functional_tests/photon_isolation_2.sin \ functional_tests/polarized_1.sin \ functional_tests/powheg_1.sin \ functional_tests/process_log.sin \ functional_tests/pythia6_1.sin \ functional_tests/pythia6_2.sin \ functional_tests/pythia6_3.sin \ functional_tests/pythia6_4.sin \ functional_tests/pythia8_1.sin \ functional_tests/pythia8_2.sin \ functional_tests/qcdtest_1.sin \ functional_tests/qcdtest_2.sin \ functional_tests/qcdtest_3.sin \ functional_tests/qcdtest_4.sin \ functional_tests/qcdtest_5.sin \ functional_tests/qcdtest_6.sin \ functional_tests/qedtest_1.sin \ functional_tests/qedtest_2.sin \ functional_tests/qedtest_3.sin \ functional_tests/qedtest_4.sin \ functional_tests/qedtest_5.sin \ functional_tests/qedtest_6.sin \ functional_tests/qedtest_7.sin \ functional_tests/qedtest_8.sin \ functional_tests/qedtest_9.sin \ functional_tests/qedtest_10.sin \ functional_tests/rambo_vamp_1.sin \ functional_tests/rambo_vamp_2.sin \ functional_tests/real_partition_1.sin \ functional_tests/rebuild_1.sin \ functional_tests/rebuild_2.sin \ functional_tests/rebuild_3.sin \ functional_tests/rebuild_4.sin \ functional_tests/rebuild_5.sin \ functional_tests/recola_1.sin \ functional_tests/recola_2.sin \ functional_tests/recola_3.sin \ functional_tests/recola_4.sin \ functional_tests/recola_5.sin \ functional_tests/recola_6.sin \ functional_tests/recola_7.sin \ functional_tests/recola_8.sin \ functional_tests/recola_9.sin \ functional_tests/resonances_1.sin \ functional_tests/resonances_2.sin \ functional_tests/resonances_3.sin \ functional_tests/resonances_4.sin \ functional_tests/resonances_5.sin \ functional_tests/resonances_6.sin \ functional_tests/resonances_7.sin \ functional_tests/resonances_8.sin \ functional_tests/resonances_9.sin \ functional_tests/resonances_10.sin \ functional_tests/resonances_11.sin \ functional_tests/resonances_12.sin \ functional_tests/resonances_13.sin \ functional_tests/resonances_14.sin \ functional_tests/resonances_15.sin \ functional_tests/restrictions.sin \ functional_tests/reweight_1.sin \ functional_tests/reweight_2.sin \ functional_tests/reweight_3.sin \ functional_tests/reweight_4.sin \ functional_tests/reweight_5.sin \ functional_tests/reweight_6.sin \ functional_tests/reweight_7.sin \ functional_tests/reweight_8.sin \ functional_tests/reweight_9.sin \ functional_tests/reweight_10.sin \ functional_tests/select_1.sin \ functional_tests/select_2.sin \ functional_tests/show_1.sin \ functional_tests/show_2.sin \ functional_tests/show_3.sin \ functional_tests/show_4.sin \ functional_tests/show_5.sin \ functional_tests/shower_err_1.sin \ functional_tests/sm_cms_1.sin \ functional_tests/smtest_1.sin \ functional_tests/smtest_2.sin \ functional_tests/smtest_3.sin \ functional_tests/smtest_4.sin \ functional_tests/smtest_5.sin \ functional_tests/smtest_6.sin \ functional_tests/smtest_7.sin \ functional_tests/smtest_8.sin \ functional_tests/smtest_9.sin \ functional_tests/smtest_10.sin \ functional_tests/smtest_11.sin \ functional_tests/smtest_12.sin \ functional_tests/smtest_13.sin \ functional_tests/smtest_14.sin \ functional_tests/smtest_15.sin \ functional_tests/smtest_16.sin \ functional_tests/smtest_17.sin \ functional_tests/spincor_1.sin \ functional_tests/static_1.exe.sin \ functional_tests/static_1.sin \ functional_tests/static_2.exe.sin \ functional_tests/static_2.sin \ functional_tests/stdhep_1.sin \ functional_tests/stdhep_2.sin \ functional_tests/stdhep_3.sin \ functional_tests/stdhep_4.sin \ functional_tests/stdhep_5.sin \ functional_tests/stdhep_6.sin \ functional_tests/structure_1.sin \ functional_tests/structure_2.sin \ functional_tests/structure_3.sin \ functional_tests/structure_4.sin \ functional_tests/structure_5.sin \ functional_tests/structure_6.sin \ functional_tests/structure_7.sin \ functional_tests/structure_8.sin \ functional_tests/susyhit.sin \ functional_tests/tauola_1.sin \ functional_tests/tauola_2.sin \ functional_tests/tauola_3.sin \ functional_tests/template_me_1.sin \ functional_tests/template_me_2.sin \ functional_tests/testproc_1.sin \ functional_tests/testproc_2.sin \ functional_tests/testproc_3.sin \ functional_tests/testproc_4.sin \ functional_tests/testproc_5.sin \ functional_tests/testproc_6.sin \ functional_tests/testproc_7.sin \ functional_tests/testproc_8.sin \ functional_tests/testproc_9.sin \ functional_tests/testproc_10.sin \ functional_tests/testproc_11.sin \ functional_tests/testproc_12.sin \ functional_tests/ufo_1.sin \ functional_tests/ufo_2.sin \ functional_tests/ufo_3.sin \ functional_tests/ufo_4.sin \ functional_tests/ufo_5.sin \ functional_tests/ufo_6.sin \ functional_tests/user_prc_threshold_1.sin \ functional_tests/user_prc_threshold_2.sin \ functional_tests/vamp2_1.sin \ functional_tests/vamp2_2.sin \ functional_tests/vamp2_3.sin \ functional_tests/vars.sin EXT_MSSM_M4 = \ ext_tests_mssm/mssm_ext-aa.m4 \ ext_tests_mssm/mssm_ext-bb.m4 \ ext_tests_mssm/mssm_ext-bt.m4 \ ext_tests_mssm/mssm_ext-dd.m4 \ ext_tests_mssm/mssm_ext-dd2.m4 \ ext_tests_mssm/mssm_ext-ddckm.m4 \ ext_tests_mssm/mssm_ext-dg.m4 \ ext_tests_mssm/mssm_ext-ee.m4 \ ext_tests_mssm/mssm_ext-ee2.m4 \ ext_tests_mssm/mssm_ext-en.m4 \ ext_tests_mssm/mssm_ext-ga.m4 \ ext_tests_mssm/mssm_ext-gg.m4 \ ext_tests_mssm/mssm_ext-gw.m4 \ ext_tests_mssm/mssm_ext-gz.m4 \ ext_tests_mssm/mssm_ext-tn.m4 \ ext_tests_mssm/mssm_ext-tt.m4 \ ext_tests_mssm/mssm_ext-ug.m4 \ ext_tests_mssm/mssm_ext-uu.m4 \ ext_tests_mssm/mssm_ext-uu2.m4 \ ext_tests_mssm/mssm_ext-uuckm.m4 \ ext_tests_mssm/mssm_ext-wa.m4 \ ext_tests_mssm/mssm_ext-ww.m4 \ ext_tests_mssm/mssm_ext-wz.m4 \ ext_tests_mssm/mssm_ext-za.m4 \ ext_tests_mssm/mssm_ext-zz.m4 EXT_NMSSM_M4 = \ ext_tests_nmssm/nmssm_ext-aa.m4 \ ext_tests_nmssm/nmssm_ext-bb1.m4 \ ext_tests_nmssm/nmssm_ext-bb2.m4 \ ext_tests_nmssm/nmssm_ext-bt.m4 \ ext_tests_nmssm/nmssm_ext-dd1.m4 \ ext_tests_nmssm/nmssm_ext-dd2.m4 \ ext_tests_nmssm/nmssm_ext-ee1.m4 \ ext_tests_nmssm/nmssm_ext-ee2.m4 \ ext_tests_nmssm/nmssm_ext-en.m4 \ ext_tests_nmssm/nmssm_ext-ga.m4 \ ext_tests_nmssm/nmssm_ext-gg.m4 \ ext_tests_nmssm/nmssm_ext-gw.m4 \ ext_tests_nmssm/nmssm_ext-gz.m4 \ ext_tests_nmssm/nmssm_ext-qg.m4 \ ext_tests_nmssm/nmssm_ext-tn.m4 \ ext_tests_nmssm/nmssm_ext-tt1.m4 \ ext_tests_nmssm/nmssm_ext-tt2.m4 \ ext_tests_nmssm/nmssm_ext-uu1.m4 \ ext_tests_nmssm/nmssm_ext-uu2.m4 \ ext_tests_nmssm/nmssm_ext-wa.m4 \ ext_tests_nmssm/nmssm_ext-ww1.m4 \ ext_tests_nmssm/nmssm_ext-ww2.m4 \ ext_tests_nmssm/nmssm_ext-wz.m4 \ ext_tests_nmssm/nmssm_ext-za.m4 \ ext_tests_nmssm/nmssm_ext-zz1.m4 \ ext_tests_nmssm/nmssm_ext-zz2.m4 EXT_MSSM_SIN = $(EXT_MSSM_M4:.m4=.sin) EXT_NMSSM_SIN = $(EXT_NMSSM_M4:.m4=.sin) EXT_ILC_SIN = \ ext_tests_ilc/ilc_settings.sin \ ext_tests_ilc/ilc_top_pair_360.sin \ ext_tests_ilc/ilc_top_pair_500.sin \ ext_tests_ilc/ilc_vbf_higgs_360.sin \ ext_tests_ilc/ilc_vbf_higgs_500.sin \ ext_tests_ilc/ilc_vbf_no_higgs_360.sin \ ext_tests_ilc/ilc_vbf_no_higgs_500.sin \ ext_tests_ilc/ilc_higgs_strahlung_360.sin \ ext_tests_ilc/ilc_higgs_strahlung_500.sin \ ext_tests_ilc/ilc_higgs_strahlung_background_360.sin \ ext_tests_ilc/ilc_higgs_strahlung_background_500.sin \ ext_tests_ilc/ilc_higgs_coupling_360.sin \ ext_tests_ilc/ilc_higgs_coupling_500.sin \ ext_tests_ilc/ilc_higgs_coupling_background_360.sin \ ext_tests_ilc/ilc_higgs_coupling_background_500.sin EXT_SHOWER_SIN = \ ext_tests_shower/shower_1_norad.sin \ ext_tests_shower/shower_2_aall.sin \ ext_tests_shower/shower_3_bb.sin \ ext_tests_shower/shower_3_jj.sin \ ext_tests_shower/shower_3_qqqq.sin \ ext_tests_shower/shower_3_tt.sin \ ext_tests_shower/shower_3_z_nu.sin \ ext_tests_shower/shower_3_z_tau.sin \ ext_tests_shower/shower_4_ee.sin \ ext_tests_shower/shower_5.sin \ ext_tests_shower/shower_6.sin EXT_NLO_SIN = \ ext_tests_nlo/nlo_ee4b.sin \ ext_tests_nlo/nlo_ee4j.sin \ ext_tests_nlo/nlo_ee4t.sin \ ext_tests_nlo/nlo_ee4tj.sin \ ext_tests_nlo/nlo_ee5j.sin \ ext_tests_nlo/nlo_eebb.sin \ ext_tests_nlo/nlo_eebbj.sin \ ext_tests_nlo/nlo_eebbjj.sin \ ext_tests_nlo/nlo_eejj.sin \ ext_tests_nlo/nlo_eejjj.sin \ ext_tests_nlo/nlo_eett.sin \ ext_tests_nlo/nlo_eetta.sin \ ext_tests_nlo/nlo_eettaa.sin \ ext_tests_nlo/nlo_eettah.sin \ ext_tests_nlo/nlo_eettaj.sin \ ext_tests_nlo/nlo_eettajj.sin \ ext_tests_nlo/nlo_eettaz.sin \ ext_tests_nlo/nlo_eettbb.sin \ ext_tests_nlo/nlo_eetth.sin \ ext_tests_nlo/nlo_eetthh.sin \ ext_tests_nlo/nlo_eetthj.sin \ ext_tests_nlo/nlo_eetthjj.sin \ ext_tests_nlo/nlo_eetthz.sin \ ext_tests_nlo/nlo_eettj.sin \ ext_tests_nlo/nlo_eettjj.sin \ ext_tests_nlo/nlo_eettjjj.sin \ ext_tests_nlo/nlo_eettwjj.sin \ ext_tests_nlo/nlo_eettww.sin \ ext_tests_nlo/nlo_eettz.sin \ ext_tests_nlo/nlo_eettzj.sin \ ext_tests_nlo/nlo_eettzjj.sin \ ext_tests_nlo/nlo_eettzz.sin \ ext_tests_nlo/nlo_ppzj_real_partition.sin \ ext_tests_nlo/nlo_pptttt.sin \ ext_tests_nlo/nlo_ppw.sin \ ext_tests_nlo/nlo_ppz.sin \ ext_tests_nlo/nlo_ppzj_sim_1.sin \ ext_tests_nlo/nlo_ppzj_sim_2.sin \ ext_tests_nlo/nlo_ppzj_sim_3.sin \ ext_tests_nlo/nlo_ppzj_sim_4.sin \ ext_tests_nlo/nlo_ppzw.sin \ ext_tests_nlo/nlo_ppzz.sin \ ext_tests_nlo/nlo_ppee_ew.sin \ ext_tests_nlo/nlo_pphee_ew.sin \ ext_tests_nlo/nlo_pphjj_ew.sin \ ext_tests_nlo/nlo_pphz_ew.sin \ ext_tests_nlo/nlo_ppllll_ew.sin \ ext_tests_nlo/nlo_ppllnn_ew.sin \ ext_tests_nlo/nlo_pptj_ew.sin \ ext_tests_nlo/nlo_ppwhh_ew.sin \ ext_tests_nlo/nlo_ppww_ew.sin \ ext_tests_nlo/nlo_ppwzh_ew.sin \ ext_tests_nlo/nlo_ppz_ew.sin \ ext_tests_nlo/nlo_ppzzz_ew.sin \ ext_tests_nlo/nlo_settings.sin \ ext_tests_nlo/nlo_settings_ew.sin EXT_NLO_ADD_SIN = \ ext_tests_nlo_add/nlo_decay_tbw.sin \ ext_tests_nlo_add/nlo_fks_delta_i_ppee.sin \ ext_tests_nlo_add/nlo_fks_delta_o_eejj.sin \ ext_tests_nlo_add/nlo_jets.sin \ ext_tests_nlo_add/nlo_methods_gosam.sin \ ext_tests_nlo_add/nlo_qq_powheg.sin \ ext_tests_nlo_add/nlo_threshold_factorized.sin \ ext_tests_nlo_add/nlo_threshold.sin \ ext_tests_nlo_add/nlo_tt_powheg_sudakov.sin \ ext_tests_nlo_add/nlo_tt_powheg.sin \ ext_tests_nlo_add/nlo_tt.sin \ ext_tests_nlo_add/nlo_uu_powheg.sin \ ext_tests_nlo_add/nlo_uu.sin all-local: $(TESTSUITES_SIN) if M4_AVAILABLE SUFFIXES = .m4 .sin .m4.sin: case "$@" in \ */*) \ mkdir -p `sed 's,/.[^/]*$$,,g' <<< "$@"` ;; \ esac $(M4) $(srcdir)/$(TESTSUITE_MACROS) $< > $@ endif M4_AVAILABLE Index: trunk/share/tests/functional_tests/ref-output/show_4.ref =================================================================== --- trunk/share/tests/functional_tests/ref-output/show_4.ref (revision 8815) +++ trunk/share/tests/functional_tests/ref-output/show_4.ref (revision 8816) @@ -1,1205 +1,1210 @@ ?openmp_logging = false [user variable] foo = PDG(11, 13, 15) [user variable] bar = ( 2.000000000000E+00, 3.000000000000E+00) ##################################################### QED.ee => 3.028600000000E-01 QED.me => 5.110000000000E-04 QED.mmu => 1.057000000000E-01 QED.mtau => 1.777000000000E+00 [undefined] sqrts = [unknown real] luminosity = 0.000000000000E+00 isr_alpha = 0.000000000000E+00 isr_q_max = 0.000000000000E+00 isr_mass = 0.000000000000E+00 +isr_q_in = -1.000000000000E+00 epa_alpha = 0.000000000000E+00 epa_x_min = 0.000000000000E+00 epa_q_min = 0.000000000000E+00 epa_q_max = 0.000000000000E+00 epa_mass = 0.000000000000E+00 ewa_x_min = 0.000000000000E+00 ewa_pt_max = 0.000000000000E+00 ewa_mass = 0.000000000000E+00 [undefined] circe1_sqrts = [unknown real] circe1_mapping_slope = 2.000000000000E+00 circe1_eps = 1.000000000000E-05 gaussian_spread1 = 0.000000000000E+00 gaussian_spread2 = 0.000000000000E+00 lambda_qcd = 2.000000000000E-01 helicity_selection_threshold = 1.000000000000E+10 safety_factor = 1.000000000000E+00 resonance_on_shell_limit = 4.000000000000E+00 resonance_on_shell_turnoff = 0.000000000000E+00 resonance_background_factor = 1.000000000000E+00 tolerance = 0.000000000000E+00 real_epsilon* = real_tiny* = accuracy_goal = 0.000000000000E+00 error_goal = 0.000000000000E+00 relative_error_goal = 0.000000000000E+00 error_threshold = 0.000000000000E+00 channel_weights_power = 2.500000000000E-01 phs_threshold_s = 5.000000000000E+01 phs_threshold_t = 1.000000000000E+02 phs_e_scale = 1.000000000000E+01 phs_m_scale = 1.000000000000E+01 phs_q_scale = 1.000000000000E+01 [undefined] x_min = [unknown real] [undefined] x_max = [unknown real] [undefined] y_min = [unknown real] [undefined] y_max = [unknown real] jet_r = 0.000000000000E+00 jet_p = 0.000000000000E+00 jet_ycut = 0.000000000000E+00 jet_dcut = 0.000000000000E+00 photon_iso_eps = 1.000000000000E+00 photon_iso_n = 1.000000000000E+00 photon_iso_r0 = 4.000000000000E-01 photon_rec_r0 = 1.000000000000E-01 ps_mass_cutoff = 1.000000000000E+00 ps_fsr_lambda = 2.900000000000E-01 ps_isr_lambda = 2.900000000000E-01 ps_fixed_alphas = 0.000000000000E+00 ps_isr_primordial_kt_width = 0.000000000000E+00 ps_isr_primordial_kt_cutoff = 5.000000000000E+00 ps_isr_z_cutoff = 9.990000000000E-01 ps_isr_minenergy = 1.000000000000E+00 ps_isr_tscalefactor = 1.000000000000E+00 hadron_enhanced_fraction = 1.000000000000E-02 hadron_enhanced_width = 2.000000000000E+00 ps_tauola_mh = 1.250000000000E+02 ps_tauola_mix_angle = 9.000000000000E+01 mlm_Qcut_ME = 0.000000000000E+00 mlm_Qcut_PS = 0.000000000000E+00 mlm_ptmin = 0.000000000000E+00 mlm_etamax = 0.000000000000E+00 mlm_Rmin = 0.000000000000E+00 mlm_Emin = 0.000000000000E+00 mlm_ETclusfactor = 2.000000000000E-01 mlm_ETclusminE = 5.000000000000E+00 mlm_etaclusfactor = 1.000000000000E+00 mlm_Rclusfactor = 1.000000000000E+00 mlm_Eclusfactor = 1.000000000000E+00 powheg_pt_min = 1.000000000000E+00 powheg_lambda = 2.000000000000E-01 blha_top_yukawa = -1.000000000000E+00 ellis_sexton_scale = -1.000000000000E+00 fks_dij_exp1 = 1.000000000000E+00 fks_dij_exp2 = 1.000000000000E+00 fks_xi_min = 0.000000000000E+00 fks_y_max = 1.000000000000E+00 fks_xi_cut = 1.000000000000E+00 fks_delta_o = 2.000000000000E+00 fks_delta_i = 2.000000000000E+00 mult_call_real = 1.000000000000E+00 mult_call_virt = 1.000000000000E+00 mult_call_dglap = 1.000000000000E+00 real_partition_scale = 1.000000000000E+01 ##################################################### QED.charged* = PDG(11, 13, 15, -11, -13, -15) ##################################################### [user variable] foo = PDG(11, 13, 15) ##################################################### [user variable] bar = ( 2.000000000000E+00, 3.000000000000E+00) ##################################################### $sf_trace_file = "" $lhapdf_dir = "" $lhapdf_file = "" $lhapdf_photon_file = "" $pdf_builtin_set = "CTEQ6L" $isr_handler_mode = "trivial" $epa_mode = "default" $epa_handler_mode = "trivial" $circe1_acc = "SBAND" [undefined] $circe2_file = [unknown string] $circe2_design = "*" [undefined] $beam_events_file = [unknown string] $negative_sf = "default" [undefined] $job_id = [unknown string] [undefined] $compile_workspace = [unknown string] $model_name = "QED" $method = "omega" $restrictions = "" $omega_flags = "" $library_name = "show_4_lib" $rng_method = "tao" $event_file_version = "" $polarization_mode = "helicity" $out_file = "" $integration_method = "vamp" $run_id = "" [undefined] $integrate_workspace = [unknown string] $vamp_grid_format = "ascii" $vamp_parallel_method = "simple" $phs_method = "default" $phs_file = "" $obs_label = "" $obs_unit = "" $title = "" $description = "" $x_label = "" $y_label = "" $gmlcode_bg = "" $gmlcode_fg = "" [undefined] $fill_options = [unknown string] [undefined] $draw_options = [unknown string] [undefined] $err_options = [unknown string] [undefined] $symbol = [unknown string] $sample = "" $sample_normalization = "auto" $rescan_input_format = "raw" $extension_raw = "evx" $extension_default = "evt" $debug_extension = "debug" $dump_extension = "pset.dat" $extension_hepevt = "hepevt" $extension_ascii_short = "short.evt" $extension_ascii_long = "long.evt" $extension_athena = "athena.evt" $extension_mokka = "mokka.evt" $lhef_version = "2.0" $lhef_extension = "lhe" $extension_lha = "lha" $extension_hepmc = "hepmc" $hepmc3_mode = "HepMC3" $extension_lcio = "slcio" $extension_stdhep = "hep" $extension_stdhep_up = "up.hep" $extension_stdhep_ev4 = "ev4.hep" $extension_hepevt_verb = "hepevt.verb" $extension_lha_verb = "lha.verb" $shower_method = "WHIZARD" $ps_PYTHIA_PYGIVE = "" $ps_PYTHIA8_config = "" $ps_PYTHIA8_config_file = "" $hadronization_method = "PYTHIA6" $born_me_method = "" $loop_me_method = "" $correlation_me_method = "" $real_tree_me_method = "" $dglap_me_method = "" $select_alpha_regions = "" $virtual_selection = "Full" $blha_ew_scheme = "alpha_internal" $openloops_extra_cmd = "" $fks_mapping_type = "default" $resonances_exclude_particles = "default" $gosam_filter_lo = "" $gosam_filter_nlo = "" $gosam_symmetries = "family,generation" $gosam_fc = "" $dalitz_plot = "" $nlo_correction_type = "QCD" $exclude_gauge_splittings = "c:b:t:e2:e3" $real_partition_mode = "default" $fc => Fortran-compiler $fcflags => Fortran-flags $fclibs => Fortran-libs ##################################################### ?sf_trace = false ?sf_allow_s_mapping = true ?hoppet_b_matching = false ?isr_recoil = false ?isr_keep_energy = false ?isr_handler = false ?isr_handler_keep_mass = true ?epa_recoil = false ?epa_keep_energy = false ?epa_handler = false ?ewa_recoil = false ?ewa_keep_energy = false ?circe1_photon1 = false ?circe1_photon2 = false ?circe1_generate = true ?circe1_map = true ?circe1_with_radiation = false ?circe2_polarized = true ?beam_events_warn_eof = true ?energy_scan_normalize = false ?logging => true ?proc_as_run_id = true ?report_progress = true [user variable] ?me_verbose = false ?omega_write_phs_output = false ?read_color_factors = true ?slha_read_input = true ?slha_read_spectrum = true ?slha_read_decays = false ?alphas_is_fixed = true ?alpha_is_fixed = true ?alphas_from_lhapdf = false ?alphas_from_pdf_builtin = false ?alpha_evolve_analytic = true ?alphas_from_mz = false ?alphas_from_lambda_qcd = false ?fatal_beam_decay = true ?helicity_selection_active = true ?vis_diags = false ?vis_diags_color = false ?check_event_file = true ?unweighted = true ?negative_weights = false ?resonance_history = false ?keep_beams = false ?keep_remnants = true ?rescan_force = false ?recover_beams = true ?update_event = false ?update_sqme = false ?update_weight = false ?use_alphas_from_file = false ?use_scale_from_file = false ?allow_decays = true ?auto_decays = false ?auto_decays_radiative = false ?decay_rest_frame = false ?isotropic_decay = false ?diagonal_decay = false ?polarized_events = false ?colorize_subevt = false ?pacify = false ?out_advance = true ?stratified = true ?use_vamp_equivalences = true ?vamp_verbose = false ?vamp_history_global = true ?vamp_history_global_verbose = false ?vamp_history_channels = false ?vamp_history_channels_verbose = false ?integration_timer = true ?check_grid_file = true ?vis_channels = false ?check_phs_file = true ?phs_only = false ?phs_keep_nonresonant = true ?phs_step_mapping = true ?phs_step_mapping_exp = true ?phs_s_mapping = true ?vis_history = false ?normalize_bins = false ?y_log = false ?x_log = false [undefined] ?draw_histogram = [unknown logical] [undefined] ?draw_base = [unknown logical] [undefined] ?draw_piecewise = [unknown logical] [undefined] ?fill_curve = [unknown logical] [undefined] ?draw_curve = [unknown logical] [undefined] ?draw_errors = [unknown logical] [undefined] ?draw_symbols = [unknown logical] ?analysis_file_only = false ?keep_flavors_when_clustering = false ?keep_flavors_when_recombining = true ?sample_pacify = false ?sample_select = true ?read_raw = true ?write_raw = true ?debug_process = true ?debug_transforms = true ?debug_decay = true ?debug_verbose = true ?dump_compressed = false ?dump_weights = false ?dump_summary = false ?dump_screen = false ?hepevt_ensure_order = false ?lhef_write_sqme_prc = true ?lhef_write_sqme_ref = false ?lhef_write_sqme_alt = true ?hepmc_output_cross_section = false ?hepmc3_write_flows = false ?allow_shower = true ?ps_fsr_active = false ?ps_isr_active = false ?ps_taudec_active = false ?muli_active = false ?shower_verbose = false ?ps_isr_alphas_running = true ?ps_fsr_alphas_running = true ?ps_isr_pt_ordered = false ?ps_isr_angular_ordered = true ?ps_isr_only_onshell_emitted_partons = false ?allow_hadronization = true ?hadronization_active = false ?ps_tauola_photos = false ?ps_tauola_transverse = false ?ps_tauola_dec_rad_cor = true ?ps_tauola_pol_vector = false ?mlm_matching = false ?powheg_matching = false ?powheg_use_singular_jacobian = false ?powheg_test_sudakov = false ?powheg_disable_sudakov = false ?ckkw_matching = false ?omega_openmp => false ?openmp_is_active* = false ?openmp_logging = false ?mpi_logging = false ?test_soft_limit = false ?test_coll_limit = false ?test_anti_coll_limit = false ?virtual_collinear_resonance_aware = true ?openloops_use_cms = true ?openloops_switch_off_muon_yukawa = false ?disable_subtraction = false ?vis_fks_regions = false ?combined_nlo_integration = false ?fixed_order_nlo_events = false ?check_event_weights_against_xsection = false ?keep_failed_events = false ?nlo_use_born_scale = false ?nlo_cut_all_real_sqmes = false ?nlo_reuse_amplitudes_fks = false ?rebuild_library = true ?recompile_library = false ?rebuild_phase_space = true ?rebuild_grids = true ?rebuild_events = true ##################################################### [undefined] sqrts = [unknown real] luminosity = 0.000000000000E+00 ?sf_trace = false $sf_trace_file = "" ?sf_allow_s_mapping = true $lhapdf_dir = "" $lhapdf_file = "" $lhapdf_photon_file = "" lhapdf_member = 0 lhapdf_photon_scheme = 0 $pdf_builtin_set = "CTEQ6L" ?hoppet_b_matching = false isr_alpha = 0.000000000000E+00 isr_q_max = 0.000000000000E+00 isr_mass = 0.000000000000E+00 isr_order = 3 +isr_log_order = 0 +isr_q_in = -1.000000000000E+00 ?isr_recoil = false ?isr_keep_energy = false ?isr_handler = false $isr_handler_mode = "trivial" ?isr_handler_keep_mass = true $epa_mode = "default" epa_alpha = 0.000000000000E+00 epa_x_min = 0.000000000000E+00 epa_q_min = 0.000000000000E+00 epa_q_max = 0.000000000000E+00 epa_mass = 0.000000000000E+00 ?epa_recoil = false ?epa_keep_energy = false ?epa_handler = false $epa_handler_mode = "trivial" ewa_x_min = 0.000000000000E+00 ewa_pt_max = 0.000000000000E+00 ewa_mass = 0.000000000000E+00 ?ewa_recoil = false ?ewa_keep_energy = false ?circe1_photon1 = false ?circe1_photon2 = false [undefined] circe1_sqrts = [unknown real] ?circe1_generate = true ?circe1_map = true circe1_mapping_slope = 2.000000000000E+00 circe1_eps = 1.000000000000E-05 circe1_ver = 0 circe1_rev = 0 $circe1_acc = "SBAND" circe1_chat = 0 ?circe1_with_radiation = false ?circe2_polarized = true [undefined] $circe2_file = [unknown string] $circe2_design = "*" gaussian_spread1 = 0.000000000000E+00 gaussian_spread2 = 0.000000000000E+00 [undefined] $beam_events_file = [unknown string] ?beam_events_warn_eof = true ?energy_scan_normalize = false $negative_sf = "default" ?logging => true [undefined] $job_id = [unknown string] [undefined] $compile_workspace = [unknown string] seed = 0 $model_name = "QED" [undefined] process_num_id = [unknown integer] ?proc_as_run_id = true lcio_run_id = 0 $method = "omega" ?report_progress = true $restrictions = "" ?omega_write_phs_output = false $omega_flags = "" ?read_color_factors = true ?slha_read_input = true ?slha_read_spectrum = true ?slha_read_decays = false $library_name = "show_4_lib" ?alphas_is_fixed = true ?alpha_is_fixed = true ?alphas_from_lhapdf = false ?alphas_from_pdf_builtin = false ?alpha_evolve_analytic = true alphas_order = 0 alpha_order = 0 alphas_nf = 5 alpha_nf = -1 alpha_nlep = 1 ?alphas_from_mz = false ?alphas_from_lambda_qcd = false lambda_qcd = 2.000000000000E-01 ?fatal_beam_decay = true ?helicity_selection_active = true helicity_selection_threshold = 1.000000000000E+10 helicity_selection_cutoff = 1000 $rng_method = "tao" ?vis_diags = false ?vis_diags_color = false ?check_event_file = true $event_file_version = "" n_events = 0 event_index_offset = 0 ?unweighted = true safety_factor = 1.000000000000E+00 ?negative_weights = false ?resonance_history = false resonance_on_shell_limit = 4.000000000000E+00 resonance_on_shell_turnoff = 0.000000000000E+00 resonance_background_factor = 1.000000000000E+00 ?keep_beams = false ?keep_remnants = true ?rescan_force = false ?recover_beams = true ?update_event = false ?update_sqme = false ?update_weight = false ?use_alphas_from_file = false ?use_scale_from_file = false ?allow_decays = true ?auto_decays = false auto_decays_multiplicity = 2 ?auto_decays_radiative = false ?decay_rest_frame = false ?isotropic_decay = false ?diagonal_decay = false [undefined] decay_helicity = [unknown integer] ?polarized_events = false $polarization_mode = "helicity" ?colorize_subevt = false tolerance = 0.000000000000E+00 checkpoint = 0 event_callback_interval = 0 ?pacify = false $out_file = "" ?out_advance = true real_range* = real_precision* = real_epsilon* = real_tiny* = $integration_method = "vamp" threshold_calls = 10 min_calls_per_channel = 10 min_calls_per_bin = 10 min_bins = 3 max_bins = 20 ?stratified = true ?use_vamp_equivalences = true ?vamp_verbose = false ?vamp_history_global = true ?vamp_history_global_verbose = false ?vamp_history_channels = false ?vamp_history_channels_verbose = false $run_id = "" n_calls_test = 0 ?integration_timer = true ?check_grid_file = true accuracy_goal = 0.000000000000E+00 error_goal = 0.000000000000E+00 relative_error_goal = 0.000000000000E+00 integration_results_verbosity = 1 error_threshold = 0.000000000000E+00 channel_weights_power = 2.500000000000E-01 [undefined] $integrate_workspace = [unknown string] vamp_grid_checkpoint = 1 $vamp_grid_format = "ascii" $vamp_parallel_method = "simple" $phs_method = "default" ?vis_channels = false ?check_phs_file = true $phs_file = "" ?phs_only = false phs_threshold_s = 5.000000000000E+01 phs_threshold_t = 1.000000000000E+02 phs_off_shell = 2 phs_t_channel = 6 phs_e_scale = 1.000000000000E+01 phs_m_scale = 1.000000000000E+01 phs_q_scale = 1.000000000000E+01 ?phs_keep_nonresonant = true ?phs_step_mapping = true ?phs_step_mapping_exp = true ?phs_s_mapping = true ?vis_history = false n_bins = 20 ?normalize_bins = false $obs_label = "" $obs_unit = "" $title = "" $description = "" $x_label = "" $y_label = "" graph_width_mm = 130 graph_height_mm = 90 ?y_log = false ?x_log = false [undefined] x_min = [unknown real] [undefined] x_max = [unknown real] [undefined] y_min = [unknown real] [undefined] y_max = [unknown real] $gmlcode_bg = "" $gmlcode_fg = "" [undefined] ?draw_histogram = [unknown logical] [undefined] ?draw_base = [unknown logical] [undefined] ?draw_piecewise = [unknown logical] [undefined] ?fill_curve = [unknown logical] [undefined] ?draw_curve = [unknown logical] [undefined] ?draw_errors = [unknown logical] [undefined] ?draw_symbols = [unknown logical] [undefined] $fill_options = [unknown string] [undefined] $draw_options = [unknown string] [undefined] $err_options = [unknown string] [undefined] $symbol = [unknown string] ?analysis_file_only = false kt_algorithm* = 0 cambridge_algorithm* = 1 antikt_algorithm* = 2 genkt_algorithm* = 3 cambridge_for_passive_algorithm* = 11 genkt_for_passive_algorithm* = 13 ee_kt_algorithm* = 50 ee_genkt_algorithm* = 53 plugin_algorithm* = 99 undefined_jet_algorithm* = 999 jet_algorithm = 999 jet_r = 0.000000000000E+00 jet_p = 0.000000000000E+00 jet_ycut = 0.000000000000E+00 jet_dcut = 0.000000000000E+00 ?keep_flavors_when_clustering = false photon_iso_eps = 1.000000000000E+00 photon_iso_n = 1.000000000000E+00 photon_iso_r0 = 4.000000000000E-01 photon_rec_r0 = 1.000000000000E-01 ?keep_flavors_when_recombining = true $sample = "" $sample_normalization = "auto" ?sample_pacify = false ?sample_select = true sample_max_tries = 10000 sample_split_n_evt = 0 sample_split_n_kbytes = 0 sample_split_index = 0 $rescan_input_format = "raw" ?read_raw = true ?write_raw = true $extension_raw = "evx" $extension_default = "evt" $debug_extension = "debug" ?debug_process = true ?debug_transforms = true ?debug_decay = true ?debug_verbose = true $dump_extension = "pset.dat" ?dump_compressed = false ?dump_weights = false ?dump_summary = false ?dump_screen = false ?hepevt_ensure_order = false $extension_hepevt = "hepevt" $extension_ascii_short = "short.evt" $extension_ascii_long = "long.evt" $extension_athena = "athena.evt" $extension_mokka = "mokka.evt" $lhef_version = "2.0" $lhef_extension = "lhe" ?lhef_write_sqme_prc = true ?lhef_write_sqme_ref = false ?lhef_write_sqme_alt = true $extension_lha = "lha" $extension_hepmc = "hepmc" ?hepmc_output_cross_section = false ?hepmc3_write_flows = false $hepmc3_mode = "HepMC3" $extension_lcio = "slcio" $extension_stdhep = "hep" $extension_stdhep_up = "up.hep" $extension_stdhep_ev4 = "ev4.hep" $extension_hepevt_verb = "hepevt.verb" $extension_lha_verb = "lha.verb" ?allow_shower = true ?ps_fsr_active = false ?ps_isr_active = false ?ps_taudec_active = false ?muli_active = false $shower_method = "WHIZARD" ?shower_verbose = false $ps_PYTHIA_PYGIVE = "" $ps_PYTHIA8_config = "" $ps_PYTHIA8_config_file = "" ps_mass_cutoff = 1.000000000000E+00 ps_fsr_lambda = 2.900000000000E-01 ps_isr_lambda = 2.900000000000E-01 ps_max_n_flavors = 5 ?ps_isr_alphas_running = true ?ps_fsr_alphas_running = true ps_fixed_alphas = 0.000000000000E+00 ?ps_isr_pt_ordered = false ?ps_isr_angular_ordered = true ps_isr_primordial_kt_width = 0.000000000000E+00 ps_isr_primordial_kt_cutoff = 5.000000000000E+00 ps_isr_z_cutoff = 9.990000000000E-01 ps_isr_minenergy = 1.000000000000E+00 ps_isr_tscalefactor = 1.000000000000E+00 ?ps_isr_only_onshell_emitted_partons = false ?allow_hadronization = true ?hadronization_active = false $hadronization_method = "PYTHIA6" hadron_enhanced_fraction = 1.000000000000E-02 hadron_enhanced_width = 2.000000000000E+00 ?ps_tauola_photos = false ?ps_tauola_transverse = false ?ps_tauola_dec_rad_cor = true ps_tauola_dec_mode1 = 0 ps_tauola_dec_mode2 = 0 ps_tauola_mh = 1.250000000000E+02 ps_tauola_mix_angle = 9.000000000000E+01 ?ps_tauola_pol_vector = false ?mlm_matching = false mlm_Qcut_ME = 0.000000000000E+00 mlm_Qcut_PS = 0.000000000000E+00 mlm_ptmin = 0.000000000000E+00 mlm_etamax = 0.000000000000E+00 mlm_Rmin = 0.000000000000E+00 mlm_Emin = 0.000000000000E+00 mlm_nmaxMEjets = 0 mlm_ETclusfactor = 2.000000000000E-01 mlm_ETclusminE = 5.000000000000E+00 mlm_etaclusfactor = 1.000000000000E+00 mlm_Rclusfactor = 1.000000000000E+00 mlm_Eclusfactor = 1.000000000000E+00 ?powheg_matching = false ?powheg_use_singular_jacobian = false powheg_grid_size_xi = 5 powheg_grid_size_y = 5 powheg_pt_min = 1.000000000000E+00 powheg_lambda = 2.000000000000E-01 ?powheg_test_sudakov = false ?powheg_disable_sudakov = false ?ckkw_matching = false ?omega_openmp => false ?openmp_is_active* = false openmp_num_threads_default* = 1 openmp_num_threads = 1 ?openmp_logging = false ?mpi_logging = false $born_me_method = "" $loop_me_method = "" $correlation_me_method = "" $real_tree_me_method = "" $dglap_me_method = "" ?test_soft_limit = false ?test_coll_limit = false ?test_anti_coll_limit = false $select_alpha_regions = "" $virtual_selection = "Full" ?virtual_collinear_resonance_aware = true blha_top_yukawa = -1.000000000000E+00 $blha_ew_scheme = "alpha_internal" openloops_verbosity = 1 ?openloops_use_cms = true openloops_phs_tolerance = 7 openloops_stability_log = 0 ?openloops_switch_off_muon_yukawa = false $openloops_extra_cmd = "" ellis_sexton_scale = -1.000000000000E+00 ?disable_subtraction = false fks_dij_exp1 = 1.000000000000E+00 fks_dij_exp2 = 1.000000000000E+00 fks_xi_min = 0.000000000000E+00 fks_y_max = 1.000000000000E+00 ?vis_fks_regions = false fks_xi_cut = 1.000000000000E+00 fks_delta_o = 2.000000000000E+00 fks_delta_i = 2.000000000000E+00 $fks_mapping_type = "default" $resonances_exclude_particles = "default" alpha_power = 2 alphas_power = 0 ?combined_nlo_integration = false ?fixed_order_nlo_events = false ?check_event_weights_against_xsection = false ?keep_failed_events = false gks_multiplicity = 0 $gosam_filter_lo = "" $gosam_filter_nlo = "" $gosam_symmetries = "family,generation" form_threads = 2 form_workspace = 1000 $gosam_fc = "" mult_call_real = 1.000000000000E+00 mult_call_virt = 1.000000000000E+00 mult_call_dglap = 1.000000000000E+00 $dalitz_plot = "" $nlo_correction_type = "QCD" $exclude_gauge_splittings = "c:b:t:e2:e3" ?nlo_use_born_scale = false ?nlo_cut_all_real_sqmes = false $real_partition_mode = "default" real_partition_scale = 1.000000000000E+01 ?nlo_reuse_amplitudes_fks = false $fc => Fortran-compiler $fcflags => Fortran-flags $fclibs => Fortran-libs ?rebuild_library = true ?recompile_library = false ?rebuild_phase_space = true ?rebuild_grids = true ?rebuild_events = true ##################################################### QED.ee => 3.028600000000E-01 QED.me => 5.110000000000E-04 QED.mmu => 1.057000000000E-01 QED.mtau => 1.777000000000E+00 QED.particle* = PDG(0) QED.E_LEPTON* = PDG(11) QED.e-* = PDG(11) QED.e1* = PDG(11) QED.e+* = PDG(-11) QED.E1* = PDG(-11) QED.MU_LEPTON* = PDG(13) QED.m-* = PDG(13) QED.e2* = PDG(13) QED.mu-* = PDG(13) QED.m+* = PDG(-13) QED.E2* = PDG(-13) QED.mu+* = PDG(-13) QED.TAU_LEPTON* = PDG(15) QED.t-* = PDG(15) QED.e3* = PDG(15) QED.ta-* = PDG(15) QED.tau-* = PDG(15) QED.t+* = PDG(-15) QED.E3* = PDG(-15) QED.ta+* = PDG(-15) QED.tau+* = PDG(-15) QED.PHOTON* = PDG(22) QED.A* = PDG(22) QED.gamma* = PDG(22) QED.photon* = PDG(22) QED.charged* = PDG(11, 13, 15, -11, -13, -15) QED.neutral* = PDG(22) QED.colored* = PDG() [undefined] sqrts = [unknown real] luminosity = 0.000000000000E+00 ?sf_trace = false $sf_trace_file = "" ?sf_allow_s_mapping = true $lhapdf_dir = "" $lhapdf_file = "" $lhapdf_photon_file = "" lhapdf_member = 0 lhapdf_photon_scheme = 0 $pdf_builtin_set = "CTEQ6L" ?hoppet_b_matching = false isr_alpha = 0.000000000000E+00 isr_q_max = 0.000000000000E+00 isr_mass = 0.000000000000E+00 isr_order = 3 +isr_log_order = 0 +isr_q_in = -1.000000000000E+00 ?isr_recoil = false ?isr_keep_energy = false ?isr_handler = false $isr_handler_mode = "trivial" ?isr_handler_keep_mass = true $epa_mode = "default" epa_alpha = 0.000000000000E+00 epa_x_min = 0.000000000000E+00 epa_q_min = 0.000000000000E+00 epa_q_max = 0.000000000000E+00 epa_mass = 0.000000000000E+00 ?epa_recoil = false ?epa_keep_energy = false ?epa_handler = false $epa_handler_mode = "trivial" ewa_x_min = 0.000000000000E+00 ewa_pt_max = 0.000000000000E+00 ewa_mass = 0.000000000000E+00 ?ewa_recoil = false ?ewa_keep_energy = false ?circe1_photon1 = false ?circe1_photon2 = false [undefined] circe1_sqrts = [unknown real] ?circe1_generate = true ?circe1_map = true circe1_mapping_slope = 2.000000000000E+00 circe1_eps = 1.000000000000E-05 circe1_ver = 0 circe1_rev = 0 $circe1_acc = "SBAND" circe1_chat = 0 ?circe1_with_radiation = false ?circe2_polarized = true [undefined] $circe2_file = [unknown string] $circe2_design = "*" gaussian_spread1 = 0.000000000000E+00 gaussian_spread2 = 0.000000000000E+00 [undefined] $beam_events_file = [unknown string] ?beam_events_warn_eof = true ?energy_scan_normalize = false $negative_sf = "default" ?logging => true [undefined] $job_id = [unknown string] [undefined] $compile_workspace = [unknown string] seed = 0 $model_name = "QED" [undefined] process_num_id = [unknown integer] ?proc_as_run_id = true lcio_run_id = 0 $method = "omega" ?report_progress = true [user variable] ?me_verbose = false $restrictions = "" ?omega_write_phs_output = false $omega_flags = "" ?read_color_factors = true ?slha_read_input = true ?slha_read_spectrum = true ?slha_read_decays = false $library_name = "show_4_lib" ?alphas_is_fixed = true ?alpha_is_fixed = true ?alphas_from_lhapdf = false ?alphas_from_pdf_builtin = false ?alpha_evolve_analytic = true alphas_order = 0 alpha_order = 0 alphas_nf = 5 alpha_nf = -1 alpha_nlep = 1 ?alphas_from_mz = false ?alphas_from_lambda_qcd = false lambda_qcd = 2.000000000000E-01 ?fatal_beam_decay = true ?helicity_selection_active = true helicity_selection_threshold = 1.000000000000E+10 helicity_selection_cutoff = 1000 $rng_method = "tao" ?vis_diags = false ?vis_diags_color = false ?check_event_file = true $event_file_version = "" n_events = 0 event_index_offset = 0 ?unweighted = true safety_factor = 1.000000000000E+00 ?negative_weights = false ?resonance_history = false resonance_on_shell_limit = 4.000000000000E+00 resonance_on_shell_turnoff = 0.000000000000E+00 resonance_background_factor = 1.000000000000E+00 ?keep_beams = false ?keep_remnants = true ?rescan_force = false ?recover_beams = true ?update_event = false ?update_sqme = false ?update_weight = false ?use_alphas_from_file = false ?use_scale_from_file = false ?allow_decays = true ?auto_decays = false auto_decays_multiplicity = 2 ?auto_decays_radiative = false ?decay_rest_frame = false ?isotropic_decay = false ?diagonal_decay = false [undefined] decay_helicity = [unknown integer] ?polarized_events = false $polarization_mode = "helicity" ?colorize_subevt = false tolerance = 0.000000000000E+00 checkpoint = 0 event_callback_interval = 0 ?pacify = false $out_file = "" ?out_advance = true real_range* = real_precision* = real_epsilon* = real_tiny* = $integration_method = "vamp" threshold_calls = 10 min_calls_per_channel = 10 min_calls_per_bin = 10 min_bins = 3 max_bins = 20 ?stratified = true ?use_vamp_equivalences = true ?vamp_verbose = false ?vamp_history_global = true ?vamp_history_global_verbose = false ?vamp_history_channels = false ?vamp_history_channels_verbose = false $run_id = "" n_calls_test = 0 ?integration_timer = true ?check_grid_file = true accuracy_goal = 0.000000000000E+00 error_goal = 0.000000000000E+00 relative_error_goal = 0.000000000000E+00 integration_results_verbosity = 1 error_threshold = 0.000000000000E+00 channel_weights_power = 2.500000000000E-01 [undefined] $integrate_workspace = [unknown string] vamp_grid_checkpoint = 1 $vamp_grid_format = "ascii" $vamp_parallel_method = "simple" $phs_method = "default" ?vis_channels = false ?check_phs_file = true $phs_file = "" ?phs_only = false phs_threshold_s = 5.000000000000E+01 phs_threshold_t = 1.000000000000E+02 phs_off_shell = 2 phs_t_channel = 6 phs_e_scale = 1.000000000000E+01 phs_m_scale = 1.000000000000E+01 phs_q_scale = 1.000000000000E+01 ?phs_keep_nonresonant = true ?phs_step_mapping = true ?phs_step_mapping_exp = true ?phs_s_mapping = true ?vis_history = false n_bins = 20 ?normalize_bins = false $obs_label = "" $obs_unit = "" $title = "" $description = "" $x_label = "" $y_label = "" graph_width_mm = 130 graph_height_mm = 90 ?y_log = false ?x_log = false [undefined] x_min = [unknown real] [undefined] x_max = [unknown real] [undefined] y_min = [unknown real] [undefined] y_max = [unknown real] $gmlcode_bg = "" $gmlcode_fg = "" [undefined] ?draw_histogram = [unknown logical] [undefined] ?draw_base = [unknown logical] [undefined] ?draw_piecewise = [unknown logical] [undefined] ?fill_curve = [unknown logical] [undefined] ?draw_curve = [unknown logical] [undefined] ?draw_errors = [unknown logical] [undefined] ?draw_symbols = [unknown logical] [undefined] $fill_options = [unknown string] [undefined] $draw_options = [unknown string] [undefined] $err_options = [unknown string] [undefined] $symbol = [unknown string] ?analysis_file_only = false kt_algorithm* = 0 cambridge_algorithm* = 1 antikt_algorithm* = 2 genkt_algorithm* = 3 cambridge_for_passive_algorithm* = 11 genkt_for_passive_algorithm* = 13 ee_kt_algorithm* = 50 ee_genkt_algorithm* = 53 plugin_algorithm* = 99 undefined_jet_algorithm* = 999 jet_algorithm = 999 jet_r = 0.000000000000E+00 jet_p = 0.000000000000E+00 jet_ycut = 0.000000000000E+00 jet_dcut = 0.000000000000E+00 ?keep_flavors_when_clustering = false photon_iso_eps = 1.000000000000E+00 photon_iso_n = 1.000000000000E+00 photon_iso_r0 = 4.000000000000E-01 photon_rec_r0 = 1.000000000000E-01 ?keep_flavors_when_recombining = true $sample = "" $sample_normalization = "auto" ?sample_pacify = false ?sample_select = true sample_max_tries = 10000 sample_split_n_evt = 0 sample_split_n_kbytes = 0 sample_split_index = 0 $rescan_input_format = "raw" ?read_raw = true ?write_raw = true $extension_raw = "evx" $extension_default = "evt" $debug_extension = "debug" ?debug_process = true ?debug_transforms = true ?debug_decay = true ?debug_verbose = true $dump_extension = "pset.dat" ?dump_compressed = false ?dump_weights = false ?dump_summary = false ?dump_screen = false ?hepevt_ensure_order = false $extension_hepevt = "hepevt" $extension_ascii_short = "short.evt" $extension_ascii_long = "long.evt" $extension_athena = "athena.evt" $extension_mokka = "mokka.evt" $lhef_version = "2.0" $lhef_extension = "lhe" ?lhef_write_sqme_prc = true ?lhef_write_sqme_ref = false ?lhef_write_sqme_alt = true $extension_lha = "lha" $extension_hepmc = "hepmc" ?hepmc_output_cross_section = false ?hepmc3_write_flows = false $hepmc3_mode = "HepMC3" $extension_lcio = "slcio" $extension_stdhep = "hep" $extension_stdhep_up = "up.hep" $extension_stdhep_ev4 = "ev4.hep" $extension_hepevt_verb = "hepevt.verb" $extension_lha_verb = "lha.verb" ?allow_shower = true ?ps_fsr_active = false ?ps_isr_active = false ?ps_taudec_active = false ?muli_active = false $shower_method = "WHIZARD" ?shower_verbose = false $ps_PYTHIA_PYGIVE = "" $ps_PYTHIA8_config = "" $ps_PYTHIA8_config_file = "" ps_mass_cutoff = 1.000000000000E+00 ps_fsr_lambda = 2.900000000000E-01 ps_isr_lambda = 2.900000000000E-01 ps_max_n_flavors = 5 ?ps_isr_alphas_running = true ?ps_fsr_alphas_running = true ps_fixed_alphas = 0.000000000000E+00 ?ps_isr_pt_ordered = false ?ps_isr_angular_ordered = true ps_isr_primordial_kt_width = 0.000000000000E+00 ps_isr_primordial_kt_cutoff = 5.000000000000E+00 ps_isr_z_cutoff = 9.990000000000E-01 ps_isr_minenergy = 1.000000000000E+00 ps_isr_tscalefactor = 1.000000000000E+00 ?ps_isr_only_onshell_emitted_partons = false ?allow_hadronization = true ?hadronization_active = false $hadronization_method = "PYTHIA6" hadron_enhanced_fraction = 1.000000000000E-02 hadron_enhanced_width = 2.000000000000E+00 ?ps_tauola_photos = false ?ps_tauola_transverse = false ?ps_tauola_dec_rad_cor = true ps_tauola_dec_mode1 = 0 ps_tauola_dec_mode2 = 0 ps_tauola_mh = 1.250000000000E+02 ps_tauola_mix_angle = 9.000000000000E+01 ?ps_tauola_pol_vector = false ?mlm_matching = false mlm_Qcut_ME = 0.000000000000E+00 mlm_Qcut_PS = 0.000000000000E+00 mlm_ptmin = 0.000000000000E+00 mlm_etamax = 0.000000000000E+00 mlm_Rmin = 0.000000000000E+00 mlm_Emin = 0.000000000000E+00 mlm_nmaxMEjets = 0 mlm_ETclusfactor = 2.000000000000E-01 mlm_ETclusminE = 5.000000000000E+00 mlm_etaclusfactor = 1.000000000000E+00 mlm_Rclusfactor = 1.000000000000E+00 mlm_Eclusfactor = 1.000000000000E+00 ?powheg_matching = false ?powheg_use_singular_jacobian = false powheg_grid_size_xi = 5 powheg_grid_size_y = 5 powheg_pt_min = 1.000000000000E+00 powheg_lambda = 2.000000000000E-01 ?powheg_test_sudakov = false ?powheg_disable_sudakov = false ?ckkw_matching = false ?omega_openmp => false ?openmp_is_active* = false openmp_num_threads_default* = 1 openmp_num_threads = 1 ?openmp_logging = false ?mpi_logging = false $born_me_method = "" $loop_me_method = "" $correlation_me_method = "" $real_tree_me_method = "" $dglap_me_method = "" ?test_soft_limit = false ?test_coll_limit = false ?test_anti_coll_limit = false $select_alpha_regions = "" $virtual_selection = "Full" ?virtual_collinear_resonance_aware = true blha_top_yukawa = -1.000000000000E+00 $blha_ew_scheme = "alpha_internal" openloops_verbosity = 1 ?openloops_use_cms = true openloops_phs_tolerance = 7 openloops_stability_log = 0 ?openloops_switch_off_muon_yukawa = false $openloops_extra_cmd = "" ellis_sexton_scale = -1.000000000000E+00 ?disable_subtraction = false fks_dij_exp1 = 1.000000000000E+00 fks_dij_exp2 = 1.000000000000E+00 fks_xi_min = 0.000000000000E+00 fks_y_max = 1.000000000000E+00 ?vis_fks_regions = false fks_xi_cut = 1.000000000000E+00 fks_delta_o = 2.000000000000E+00 fks_delta_i = 2.000000000000E+00 $fks_mapping_type = "default" $resonances_exclude_particles = "default" alpha_power = 2 alphas_power = 0 ?combined_nlo_integration = false ?fixed_order_nlo_events = false ?check_event_weights_against_xsection = false ?keep_failed_events = false gks_multiplicity = 0 $gosam_filter_lo = "" $gosam_filter_nlo = "" $gosam_symmetries = "family,generation" form_threads = 2 form_workspace = 1000 $gosam_fc = "" mult_call_real = 1.000000000000E+00 mult_call_virt = 1.000000000000E+00 mult_call_dglap = 1.000000000000E+00 $dalitz_plot = "" $nlo_correction_type = "QCD" $exclude_gauge_splittings = "c:b:t:e2:e3" ?nlo_use_born_scale = false ?nlo_cut_all_real_sqmes = false $real_partition_mode = "default" real_partition_scale = 1.000000000000E+01 ?nlo_reuse_amplitudes_fks = false $fc => Fortran-compiler $fcflags => Fortran-flags $fclibs => Fortran-libs ?rebuild_library = true ?recompile_library = false ?rebuild_phase_space = true ?rebuild_grids = true ?rebuild_events = true [user variable] foo = PDG(11, 13, 15) [user variable] bar = ( 2.000000000000E+00, 3.000000000000E+00) | WHIZARD run finished. |=============================================================================| Index: trunk/share/tests/functional_tests/ref-output/process_log.ref =================================================================== --- trunk/share/tests/functional_tests/ref-output/process_log.ref (revision 8815) +++ trunk/share/tests/functional_tests/ref-output/process_log.ref (revision 8816) @@ -1,565 +1,567 @@ ############################################################################### Process [scattering]: 'process_log_1_p1' Run ID = '' Library name = 'process_log_lib' Process index = 1 Process components: 1: 'process_log_1_p1_i1': e-, e+ => m-, m+ [omega] ------------------------------------------------------------------------ ############################################################################### Integral = 8.3556567814E+03 Error = 3.2359019246E+00 Accuracy = 1.8972317270E-02 Chi2 = 5.2032955661E-01 Efficiency = 7.8315602603E-01 T(10k evt) =